home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FFA.ZIP / WFL.SEQ < prev    next >
Encoding:
Text File  |  1987-12-10  |  8.8 KB  |  225 lines
  1. \ WFL.SEQ       Window file selection.                  by Tom Zimmer
  2.  
  3. ONLY FORTH ALSO HIDDEN DEFINITIONS ALSO
  4.  
  5. create rootdir ascii . c, 0 c,   \ root is . & null
  6.  
  7.   14 constant b/fnam             \ bytes per filename
  8.  
  9. : maxdir sp@ 100 - here 300 + - b/fnam / abs ;
  10.  
  11.    5 constant forg              \ top of file window display
  12.   15 constant dlen              \ directory window length
  13.   16 constant dirattrib         \ directory file attribute
  14.  
  15.      variable #fls              \ number of files present
  16.      variable curfl             \ current file number
  17.      variable foff
  18.  
  19. : >fadr         ( n1 --- a1 )
  20.                 b/fnam * ( first ) here 300 + + 1+ ;
  21.  
  22. : .nam          ( n1 --- )
  23.                 >fadr dup count swap over type
  24.                 12 swap - spaces 1- c@ dirattrib and
  25.                 if      #out @ 1- #line @ at
  26.                         ." ∞"
  27.                 then    ;
  28.  
  29. create excludes ," COMEXEARCBAKBINDRVMAPOBJBLKOVR"
  30.  
  31. variable exlist excludes exlist !
  32. variable exsrc
  33.  
  34. : ?exclude      ( --- f1 )      \ f1 = true if in exclude list
  35.                 pad 30 + dup 12 over + swap
  36.                 do      i c@ ascii . =
  37.                         if      drop i 1+ leave
  38.                         then
  39.                 loop    exsrc !
  40.                 0 exlist @ ?dup 0= if exit then    \ Leave if exlist=0
  41.                 count over + swap
  42.                ?do      i exsrc @ 3 comp 0= or
  43.              3 +loop    ;
  44.  
  45. : name>buf      ( --- )         \ move name from dta to buffer
  46.                 #fls @ >fadr >r
  47.                 pad 30 + 12 dup 0
  48.                 do      over i + c@ 0=
  49.                         if      drop i leave
  50.                         then
  51.                 loop    dup r@ c! r@ 1+ swap cmove
  52.                 pad 21 + c@ r> 1- c! ;
  53.  
  54. : $getdir       ( a1 --- )
  55.                 shndl+ $>handle         \ get directory spec
  56.                 curfl off foff off #fls off
  57.                 pad SET-DTA
  58.                 shndl+  >nam findfirst
  59.                 begin   255 and 0= #fls @ maxdir > 0= and
  60.                 while   ?exclude 0=
  61.                         if    name>buf #fls incr
  62.                         then  findnext
  63.                 repeat  ;
  64.  
  65. : getdir        ( --- )
  66.                 " *.*" ">$ $getdir ;
  67.  
  68. : -ss           0 do 196 emit loop ;
  69.  
  70. : -ll           ( l r len line --- )
  71.                 17 swap forg + at rot emit -ss emit ;
  72.  
  73. : showdrives    ( --- )
  74.                 218 191 57 12 -ll 17 forg 13 + at 179 emit
  75.                 ."  Press -  A B C D E F G H I  - to select a disk drive. "
  76.                 2  spaces 179 emit 192 217 57 14 -ll ;
  77.  
  78. : showret       ( --- )
  79.                 17 forg 4 + at 179 emit
  80.                 space 17 emit 196 emit 217 emit
  81.                 ."  = Select file/directory "     179 emit
  82.                 17 forg 5 + at 179 emit
  83.                 ."  Esc = Cancel file selection " 179 emit
  84.                 17 forg 6 + at 179 emit
  85.                 ."  Del = Delete a file         " 179 emit
  86.                 17 forg 7 + at 179 emit
  87.                 ."    \ = Type a new path name  " 179 emit
  88.                 192 217 29 8 -ll ;
  89.  
  90. : showkeys      ( --- )         \ show some help
  91.                 218 191 16 -1 -ll
  92.                 17 forg    at "   Hom   x   PgUp  "  >r
  93.                 179 over  c! 179 over 6 + c! 24 over 8 + c!
  94.                 179 over 10 + c! 179 over 17 + c! r> type
  95.                 17 forg 1+ at 179 emit space 4 -ss 197 emit
  96.                 3 -ss 197 emit 5 -ss space 179 emit
  97.                 17 forg 2+ at "   End   x   PgDn  " >r
  98.                 179 over c! 179 over 6 + c! 25 over 8 + c!
  99.                 179 over 10 + c! 179 over 17 + c! r> type
  100.                 ( 192 217 ) 195 193 16 3 -ll 12 -SS 191 EMIT
  101.                 showret showdrives ;
  102.  
  103. : pathbox       ( --- )
  104.                 218 191 57 9 -ll 17 forg 10 + at 179 emit
  105.                ."  Path = " 0 25 bdos 65 + emit ." :\"
  106.                 46 spaces 179 emit 192 217 57 11 -ll ;
  107.  
  108. : showpath      ( --- )
  109.                 pathbox 28 forg 10 + at pad 64 erase
  110.                 pad 0 pdos 0=
  111.                 if      ." \" pad 64 over + swap
  112.                         do   i c@ ?dup if emit else leave then
  113.                         loop
  114.                 else    ." Can't read path"
  115.                 then    ;
  116.  
  117. : showdir       ( --- )         \ display cirectory window
  118.                 #out @ #line @ >r >r 1 forg 1- at
  119.                 218 emit 14 0 do 196 emit loop 191 emit dlen 0
  120.         do      1 i forg + at i foff @ + #fls @ >= 179 emit
  121.                 if      i 0= if      ." ...No Files..."
  122.                              else    b/fnam spaces  then
  123.                 else    curfl @ i foff @ + =
  124.                         if      ( 221 ) 16 emit
  125.                                 i foff @ + .nam
  126.                                 ( 222 ) 17 emit
  127.                         else    space i foff @ + .nam space
  128.                         then
  129.                 then    179 emit
  130.         loop    1 forg dlen + at 192 emit 14 0 do 196 emit loop
  131.                 217 emit r> r> at ;
  132.  
  133. : nfl           ( --- )         \ next file
  134.                 curfl @ #fls @ 1- 0 max = if exit then
  135.                 curfl @ 1+ #fls @ 1- min 0 max dup curfl !
  136.                 dup #fls @ < swap dlen 1- - foff @ = and
  137.                 if      foff @ 1+ #fls @ 15 - 0 max min foff !
  138.                 then    ;
  139.  
  140. : pfl           ( --- )         \ previous file
  141.                 curfl @ 1- 0 max dup curfl !
  142.                 foff @ =
  143.                 if      foff @ 1- 0 max foff !
  144.                 then    ;
  145.  
  146. : 0fl           ( --- )         \ first file
  147.                 curfl off foff off ;
  148.  
  149. : efl           ( --- )
  150.                 begin nfl curfl @ #fls @ 1- 0 max = until ;
  151.  
  152. : delfl         ( --- )
  153.         curfl @ >fadr dup >r 1- c@ dirattrib and
  154.         19 forg 10 + 2dup at  55 spaces at
  155.         if      ." Can't delete directory !" beep    1 seconds
  156.         else    ." Delete '" r@ count type ." ' <- Y/N [N] "
  157.                 cursor-on key cursor-off bl or ascii y =
  158.                 if      sequp
  159.                         r@ shndl @ $>handle
  160.                         shndl @ hdelete 5 =
  161.                         if      ."  Access denied !"
  162.                                 beep 1 seconds
  163.                         then    seqdown
  164.                 then    curfl @  foff @ getdir
  165.                          foff ! curfl !
  166.         then    r> drop showpath ;
  167.  
  168. : ndir          ( --- )
  169.                 begin   cursor-on pathbox ascii \ pad c!
  170.                         29 forg 10 + at pad 1+ 50 expect
  171.                         span @ pad 1+ + off
  172.                         pad 59 bdos
  173.                 while   ."  <- Invalid Path" beep 1 seconds
  174.                 repeat  cursor-off getdir showpath 0fl ;
  175.  
  176. : ndriv         ( n1 --- n1 )
  177.                 dup bl or 97 - 0 max select
  178.                 getdir showpath 0fl ;
  179.  
  180. : keytests      ( n1 --- )
  181.                 dup false = if  ( do nothing ) else
  182. ( up arrow )    dup   200 = over 56 = or if pfl             else
  183. ( down arrow )  dup   208 = over 50 = or if nfl             else
  184. ( PgUp )        dup   201 = over 57 = or if dlen 1- 0 do pfl loop else
  185. ( PgDn )        dup   209 = over 51 = or if dlen 1- 0 do nfl loop else
  186. ( \ )           dup    92 =              if ndir            else
  187. ( A to I )      dup bl or ascii a ascii i between
  188.                                          if ndriv           else
  189. ( Del )         dup   211 = over 46 = or if delfl           else
  190. ( Home )        dup   199 = over 55 = or if 0fl             else
  191. ( End )         dup   207 = over 49 = or if efl             else   beep
  192.                 then then then then then then then then then then drop ;
  193.  
  194. : ?setdir       ( c1 --- c2 f1 ) \ return bool false if new dir
  195.                 curfl @ >fadr dup >r 1- c@ dirattrib and
  196.                 if      drop
  197.                         r@ count swap pad 2 pick cmove
  198.                         pad + off pad @ rootdir @ =
  199.                         if      ascii \ pad c!
  200.                         then    pad 59 bdos  drop
  201.                         cursor-off getdir showpath 0fl
  202.                         false false
  203.                 else    true
  204.                 then    r> drop ;
  205.  
  206. ONLY FORTH DEFINITIONS ALSO HIDDEN ALSO
  207.  
  208. : <getfile>     ( --- <a1> f1 )   \ return a1 filename addr and
  209.                #out @ #line @ >r >r savescr cursor-off getdir
  210.                0fl showkeys showpath
  211.                begin    showdir 0 0 at
  212.                         key dup 13 = dup
  213.                         if      drop ?setdir ( c1 --- c2 f1 )
  214.                         then    over 27 = or 0=
  215.                while    keytests
  216.                repeat   13 = dup
  217.                if       curfl @ >fadr dup c@ 1+ pad >r r@
  218.                         swap cmove r> swap
  219.                then     r> r> at
  220.                restscr  cursor-on
  221.                #fls @ 0<> and ;
  222.  
  223. ' <getfile> is getfile          \ patch in window get file.
  224.  
  225.