home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / LASER / FPC35_5.ZIP / FPCSRC.ZIP / WFL.SEQ < prev    next >
Encoding:
Text File  |  1989-09-05  |  16.2 KB  |  416 lines
  1. \ WFL.SEQ       Window file selection.                  by Tom Zimmer
  2.  
  3. ONLY FORTH ALSO HIDDEN DEFINITIONS ALSO
  4.  
  5. create rootdir '.' c, 0 c,   \ root is . & null
  6. handle dirhndl
  7.  
  8. defer wflbutton ' noop is wflbutton
  9.  
  10. headerless
  11.  
  12. create itemstk 10 allot
  13.        itemstk 10 erase
  14.  
  15. variable item#
  16.          item# off
  17.  
  18. variable flitem
  19.          flitem off
  20.  
  21. : setfl         ( n1 --- )
  22.                 flitem ! ;
  23.  
  24. \     Item stack used to hold Directory offsets in window while stepping
  25. \     up and down the directory tree.
  26.  
  27. : 0istk         ( --- )             \ Clear the item stack
  28.                 itemstk 10 erase
  29.                 item# off ;
  30.  
  31. : >istk         ( n1 --- )          \ put an item on the item stack
  32.                 item# @ itemstk + c!
  33.                 item# @ 1+ 9 min item# ! ;
  34.  
  35. : istk>         ( --- n1 )          \ get an item from the item stack.
  36.                 item# @ 1- 0MAX dup item# !
  37.                 itemstk + dup c@ swap off ;
  38.  
  39. headers
  40.  
  41. create dirspec$ ," *.*" b/hcb allot
  42.     -1 dirspec$ >hndle !
  43.        dirspec$ count + off
  44.  
  45. create defdirspec$ ," *.*" 20 allot
  46.  
  47.    14 constant b/fnam           \ bytes per filename
  48.   300 constant maxdir
  49.  
  50. b/fnam maxdir * paragraph 4 +   \ room for directory entries plus a couple
  51.      constant #dirsegs
  52.    4 constant forgx
  53.    3 constant forgy             \ top of file window display
  54.   18 constant dlen              \ directory window length
  55.  
  56.    0 value dirseg
  57.    0 value dirrow
  58.    0 value #fls                 \ number of files present
  59.    0 value curfl                \ current file number
  60.    0 value foff
  61.  
  62. headerless
  63.  
  64.   16 constant dirattrib         \ directory file attribute
  65.      variable aletter
  66.  
  67. headers
  68.  
  69. : dirinit       ( --- )                 \ try to initialize the directory
  70.                 defers initstuff        \ yet initialized.
  71.                 off> dirseg
  72.                 #dirsegs alloc 8 =
  73.                 if      2drop
  74.                             ." \n\bNo room for directory buffer!, "
  75.                                 ." Can't pop up Dir window. Sorry!\n\:10"
  76.                 else    nip =: dirseg
  77.                 then    rows forgy - 4 - =: dlen ;
  78.  
  79. ' dirinit is initstuff
  80.  
  81. headerless
  82.  
  83. code foff+      ( n1 --- n2 )
  84.                 pop ax
  85.                 add ax, ' foff >body
  86.                 1push
  87.                 end-code
  88.  
  89. headers
  90.  
  91. code >fadr      ( name# -- seg name_offset )
  92.                 pop ax
  93.                 mov bx, # b/fnam
  94.                 mul bx                  \ b/fnam *
  95.                 add ax, # 1             \ 1+
  96.                 mov dx, ' dirseg >body  \ dirseg
  97.                 2push
  98.                 end-code
  99.  
  100. : dir>pad      ( seg off --- a1 n1 )
  101.                 2dup c@l >r ?cs: pad r@ 1+ cmovel pad 1+ r> ;
  102.  
  103. : .nam          ( n1 --- )
  104.                 >fadr dup>r dir>pad dup>r type
  105.                 12 r> - spaces
  106.                 dirseg r> 1- c@l dirattrib and
  107.                 if      #out @ 1- #line @ at
  108.                         ." ∞"
  109.                 then    ;
  110.  
  111. : name>buf      ( --- )         \ move name from dta to buffer
  112.                 #fls >fadr nip >r
  113.                 pad 30 + 12 dup 0
  114.                 do      over i + c@ 0=
  115.                         if      drop i leave
  116.                         then
  117.                 loop    dup dirseg r@ c!l
  118.                         >r ?cs: swap dirseg r> r@ 1+ swap cmovel
  119.                 pad 21 + c@ dirseg r> 1- c!l ;
  120.  
  121. : $getdir       ( a1 --- )
  122.                 dirhndl $>handle         \ get directory spec
  123.                 dirhndl pathset drop
  124.                 off> curfl
  125.                 off> foff
  126.                 off> #fls
  127.                 pad SET-DTA
  128.                 dirhndl >nam findfirst
  129.                 begin   255 and 0= #fls maxdir > 0= and
  130.                 while   name>buf incr> #fls
  131.                         findnext
  132.                 repeat  ;
  133.  
  134. : getdir        ( --- )
  135.                 dirspec$ $getdir ;
  136.  
  137. headerless
  138.  
  139. : (at.")        ( x1 y1 | text --- x1 y1+1 )
  140.                 2dup at
  141.                 2r@ 2dup c@l >r 1+ r@ typeL r> 1+ xeven r> + >r
  142.                 1+ ;
  143.  
  144. : at."          ( x1 y1 | text --- x1 y1+1 )
  145.                 compile (at.") x," ; immediate
  146.  
  147. : showkeys      ( --- )                 \ show some help
  148.                 forgx forgy 17 -1 d+
  149.                 at." ┌────────────────┐"
  150.                 at." │ Hom │  │ PgUp │"
  151.                 at." │ ────┼───┼───── │"
  152.                 at." │ End │  │ PgDn │"
  153.                 at." ├────────────────┴─────────────────────┐"
  154.                 at." │ A-Z = Next file starting with Letter │"
  155.                 at." │ ─┘ = Select file or directory       │"
  156.                 at." │ Esc = Cancel file selection          │"
  157.                 at." │ Del = Delete selected file           │"
  158.                 at." │   \ = Type in a new Directory Spec.  │"
  159.                 at." └──────────────────────────────────────┘" 2drop ;
  160.  
  161. : pathbox       ( --- )
  162.                 forgx forgy 17 10 d+ 2dup 52 2 d+ box&fill
  163.                 ."  Path = " ;
  164.  
  165. : showpath      ( --- )
  166.                 pathbox forgx forgy 26 11 d+ at
  167.                 dirspec$ dup pathset 0=
  168.                 if      count type
  169.                 else    ." Can't read path" drop
  170.                 then    ;
  171.  
  172. headers
  173.  
  174. : showdir       ( --- )         \ display directory window
  175.                 savecursor
  176.                 forgx forgy 1- 2dup 15 dlen 1+ d+ box
  177.                 forgx 15 + forgy        at ." \r"
  178.                 forgx 15 + forgy dlen + at ." \r"
  179.                 dlen 0
  180.         do      forgx forgy 1 i d+ at i foff+ #fls >=
  181.                 if      i 0= if      ." ...No Files..."
  182.                              else    ."               " then
  183.                 else    curfl i foff+ =
  184.                         if      i =: dirrow
  185.                                 >attrib1 ." ■" i foff+ .nam ." ■"
  186.                                 >norm
  187.                         else             ."  " i foff+ .nam ."  "
  188.                         then
  189.                 then
  190.         loop    restcursor ;
  191.  
  192. : nfl           ( --- )         \ next file
  193.                 curfl #fls 1- 0MAX = if exit then
  194.                 curfl 1+ #fls 1- min 0MAX dup !> curfl
  195.                 dup #fls < swap dlen 1- - foff = and
  196.                 if      foff 1+ #fls 15 - 0MAX min !> foff
  197.                 then    ;
  198.  
  199. : pfl           ( --- )         \ previous file
  200.                 curfl 1- 0MAX dup !> curfl
  201.                 foff =
  202.                 if      foff 1- 0MAX !> foff
  203.                 then    ;
  204.  
  205. headerless
  206.  
  207. : ?lmatch       ( --- f1 )
  208.                 curfl >fadr 1+ c@l aletter c@ = ;
  209.  
  210. : gotofl        ( --- )
  211.                 flitem @ 0MAX
  212.                 curfl over >
  213.                 if      curfl swap do pfl loop
  214.                 else    curfl     ?do nfl loop
  215.                 then    ;
  216.  
  217. : 0fl           ( --- )         \ first file
  218.                 0 !> curfl
  219.                 0 !> foff ;
  220.  
  221. variable foffsave
  222. variable curflsave
  223.  
  224. : find_letter   ( c1 --- c1 )       \ search for a file starting with c1
  225.                 95 and dup aletter c! curfl >r
  226.                 curfl #fls 1- 0MAX =
  227.                 if      0fl
  228.                 else    nfl
  229.                 then
  230.                 begin   ?lmatch curfl #fls 1- 0MAX = or 0=
  231.                 while   nfl
  232.                 repeat  ?lmatch 0=
  233.                 if      0fl r@ 0
  234.                         ?do     ?lmatch ?leave nfl
  235.                         loop    ?lmatch
  236.                         if      foffsave @
  237.                                 curflsave @ curfl - 1+ dlen >=
  238.                                 if      curfl
  239.                                 then    =: foff
  240.                         then
  241.                 else    foff foffsave ! curfl curflsave !
  242.                 then    ?lmatch 0= if beep then
  243.                 r>drop ;
  244.  
  245. : efl           ( --- )       \ goto end of file list
  246.                 begin nfl curfl #fls 1- 0MAX = until ;
  247.  
  248. headers
  249.                                         \ from counted string=a1
  250. : >pathend"     ( a1 --- a2 n1 )        \ return a2 and count=n1 of filename
  251.                 count
  252.                 begin   2dup '\' scan ?dup
  253.                 while   2swap 2drop 1 -1 d+
  254.                 repeat  drop ;
  255.  
  256.                                 \ a1 = counted string address
  257. : >pathend      ( a1 --- a2 )   \ a2 = the address of the char beyond last \
  258.                 >pathend" drop ;
  259.  
  260. : >pathend-1    ( a1 --- a2 )
  261.                 dup c@ >r               \ save old length
  262.                 dup>r >pathend          \ find last backslash
  263.                 r@ - 2- 0MAX r@ c!     \ adjust to new count
  264.                 r@ >pathend             \ find previous backslash
  265.                 r> r> swap c! ;         \ restore old length
  266.  
  267. headerless
  268.  
  269. : delfl         ( --- )                   \ delete the current file
  270.         curfl >fadr dup>r 1- c@l dirattrib and
  271.         forgx forgy 19 11 d+ 2dup at 50 spaces at
  272.         if      ." Can't delete directory !\b\:10"
  273.         else    ." Delete \`" dirseg r@ dir>pad type ." \` <- Y/N [N] "
  274.                 cursor-on key cursor-off bl or 'y' =
  275.                 if      dirspec$ >pathend dirspec$ 1+ - dup dirhndl c!
  276.                         dirspec$ 1+ dirhndl 1+ rot cmove
  277.                         dirseg r@ dir>pad >r dirhndl count + r@ cmove
  278.                         r> dirhndl c+!
  279.                         dirhndl count + off
  280.                         dirhndl hdelete 5 =
  281.                         if      ."  Access denied !\b\:10"
  282.                         then
  283.                 then    curfl foff
  284.                         getdir
  285.                         !> foff !> curfl
  286.         then    r>drop showpath ;
  287.  
  288. : ndir          ( --- )             \ Enter a NEW directory spec
  289.                 forgx forgy 17 14 d+ at
  290.                 ." Edit the Directory Spec, and press Enter. ESC=Cancel"
  291.                 cursor-on pathbox
  292.                 on> autoclear
  293.                 >attrib1
  294.                 forgx forgy 26 11 d+ dirspec$ 41 lineeditor drop
  295.                 >norm
  296.                 forgx forgy 17 14 d+ at 52 spaces
  297.                 dirspec$ count + 1- c@ dup '\' = swap ':' = or
  298.                 if      defdirspec$ count >r dirspec$ count + r@ cmove
  299.                              r> dirspec$ c+!
  300.                 then    dirspec$ c@ 0=
  301.                 if      defdirspec$ dirspec$ over c@ 1+ cmove
  302.                 then    0 dirspec$ count + c!
  303.                 dirspec$ pathset drop
  304.                 cursor-off getdir showpath 0fl ;
  305.  
  306. : keytests      ( n1 --- )
  307.                 dup false = if  ( do nothing ) else
  308. ( up arrow )    dup   200 = over 56 = or if pfl             else
  309. ( down arrow )  dup   208 = over 50 = or if nfl             else
  310. ( PgUp )        dup   201 = over 57 = or if dlen 2/ 0 ?do pfl loop else
  311. ( PgDn )        dup   209 = over 51 = or if dlen 2/ 0 ?do nfl loop else
  312. ( \ )           dup    92 =              if ndir            else
  313. ( 0 to 9)         dup '0' '9' between over bl or
  314. ( A to Z)             'a' 'z' between or if find_letter     else
  315. ( Del )         dup   211 = over 46 = or if delfl           else
  316. ( Home )        dup   199 = over 55 = or if 0fl             else
  317. ( End )         dup   207 = over 49 = or if efl             else   beep
  318.                 then then then then then then then then then then
  319.                 drop ;
  320.  
  321. : ?setdir       ( c1 --- c2 f1 ) \ return bool false if new dir
  322.             curfl >fadr dup>r 1- c@l dirattrib and      \ are we on a DIR
  323.             if    drop
  324.                   dirseg r@ dir>pad + off       \ move DIR to PAD, nul term
  325.                   pad 1+ @ rootdir @ =          \ is DIR the ROOT?
  326.                   if    dirspec$ 2+ c@ ':' =      \ include drive?
  327.                         if      '\' dirspec$ 3 + c! 3 dirspec$ c!
  328.                                 defdirspec$ count >r
  329.                                 dirspec$ count + r@ cmove r> dirspec$ c+!
  330.                         else    defdirspec$ dirspec$ over c@ 1+ cmove
  331.                         then    dirspec$ count + off  \ nul term
  332.                         begin   item# @ 1 >           \ Clear DIR stack
  333.                         while   istk> drop
  334.                         repeat  istk> setfl           \ set to ROOT
  335.                   else  pad 1+ @ " .." drop @ =       \ pop one level?
  336.                         if    \ Now we need to remove a Dir from DIRSPEC$.
  337.                               \ so step through DIRSPEC to next to the last
  338.                               \ directory.
  339.                               dirspec$ >pathend-1 dirspec$ 1+ - dirspec$ c!
  340.                               \ Append *.* to current directory specification
  341.                               defdirspec$ count >r dirspec$ count + r@ cmove
  342.                               r> dirspec$ c+!
  343.                               dirspec$ count + off    \ nul terminate
  344.                               istk> setfl             \ pop DIR stack
  345.  
  346.                         else  \ Must be on a directory name other than
  347.                               \ "." or ".." so step down to that directory
  348.  
  349.                               dirspec$ >pathend dup   \ set dirspec length
  350.                               dirspec$ 1+ - dirspec$ c!
  351.                                                       \ append DIR from PAD
  352.                                                       \ to dirspec
  353.                               pad count >r swap r@ cmove
  354.                               r> dirspec$ c+!         \ set length
  355.                               " \" >r dirspec$ count + r@ cmove \ append "\"
  356.                               r> dirspec$ c+!
  357.                               defdirspec$ count >r dirspec$ count + r@ cmove
  358.                               r> dirspec$ c+!         \ append *.*
  359.                               dirspec$ count + off    \ null terinate
  360.                               curfl >istk             \ save directory offset
  361.                               0 setfl                 \ reset offset to zero
  362.                         then
  363.                   then              \ get new directory, and show the path
  364.                   cursor-off getdir showpath gotofl
  365.                   false false
  366.             else  true
  367.             then  r>drop ;
  368.  
  369. headers
  370.  
  371. FORTH DEFINITIONS
  372.  
  373. : <getfile> ( --- <a1> f1 )   \ return a1 filename addr and boolean
  374.             dirseg 0= if false exit then  \ if it didn't work, then leave
  375.             ['] wflbutton save!> dobutton \ init mouse support
  376.             savecursor
  377.             savescr    \ save cursor and screen
  378.             forgx 2- forgy 2- over 74 + rows 3 - box&fill
  379.             forgx forgy 36 1 d+ at                 \ then my message
  380.             ." \r Tom's Window File Selection Tool "
  381.             forgx forgy 20 7 d+ at
  382.             ." \2 Reading Directory Files... "
  383.             cursor-off getdir        \ clear screen, and get dir
  384.             0fl showkeys showpath         \ show the keys and dir path
  385.             forgx forgy 17 16 d+ at               \ and som help information
  386.             ." Use  to pick a file, or press the first letter of"
  387.             forgx forgy 17 17 d+ at
  388.             ." the file you want, then press Return to select it."
  389.             begin   showdir 0 0 at        \ show the directory
  390.                   key dup 13 = dup        \ wait for a key, if Enter
  391.                   if      drop ?setdir ( c1 --- c2 f1 )     \ try to set dir
  392.                   then    over 27 = or 0= \ else check for escape or null
  393.             while   keytests        \ if neither then try to find a file
  394.             repeat  13 = dup        \ if it was Enter, then get the file name
  395.                                     \ we are on and move it to PAD. Prepend
  396.                                     \ the DIR spec.
  397.             if    dirspec$ >pathend dirspec$ 1+ - >r
  398.                   dirspec$ pad r@ 1+ cmove r> pad c!
  399.                   curfl >fadr 2dup c@l >r 1+
  400.                   ?cs: pad count + r@ cmovel r> pad c+!
  401.                   pad handle>ext c@ '.' <>      \ append '.' if no extension
  402.                   if    '.' pad count + c!
  403.                         1 pad c+!
  404.                   then  pad swap
  405.             then
  406.             restscr                     \ restore screen
  407.             restcursor                  \ restore cursor position
  408.             restore> dobutton
  409.             #fls 0<> and ;              \ return boolean for file selected
  410.  
  411. ' <getfile> is getfile          \ patch in window get file.
  412.  
  413. behead
  414.  
  415.  
  416.