home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / wfl.seq < prev    next >
Text File  |  1991-02-11  |  17KB  |  436 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.    4 constant forgx
  51.    3 constant forgy             \ top of file window display
  52.   18 constant dlen              \ directory window length
  53.  
  54. b/fnam maxdir *D 64. d+         \ room for directory entries plus a couple
  55.         pointer dirseg
  56.  
  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. \                 dirseg 0=
  72. \                 if      ." \n\bNo room for directory buffer!, "
  73. \                             ." Can't pop up Dir window. Sorry!\n\:10"
  74. \                 then    rows forgy - 4 - =: dlen ;
  75. \
  76. \ ' dirinit is initstuff
  77. \
  78. \ headerless
  79.  
  80. : dirseg_release ( -- )
  81.                 unpointer> dirseg ;
  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.                 dirseg 0= ?exit         \ leave if no directory space
  128.                 pad SET-DTA
  129.                 dirhndl >nam findfirst
  130.                 begin   255 and 0= #fls maxdir > 0= and
  131.                 while   name>buf incr> #fls
  132.                         findnext
  133.                 repeat  ;
  134.  
  135. \ 05/25/90 tjz added from Mike Christopher
  136.  
  137. : sortdir ( -- )          \ rearrange directory to ascending ascii order
  138.         #fls 2 > if
  139.                #fls 1-  0  ?do
  140.                #fls i 1+ ?do
  141.                  i >fadr 1- ?cs: pad 120 +  b/fnam cmovel
  142.                  j >fadr 1- ?cs: pad 150 +  b/fnam cmovel
  143.                  pad 121 + count pad 151 + count rot  max  comp   0<
  144.                  if
  145.                     ?cs: pad 120 + j >fadr 1- b/fnam cmovel
  146.                     ?cs: pad 150 + i >fadr 1- b/fnam cmovel
  147.                  then
  148.                loop
  149.             loop
  150.         then
  151.         ;
  152.  
  153. : getdir        ( --- )
  154.                 dirspec$ $getdir sortdir ;      \ 05/25/90 tjz
  155.  
  156. headerless
  157.  
  158. : (at.")        ( x1 y1 | text --- x1 y1+1 )
  159.                 2dup at
  160.                 2r@ 2dup c@l >r 1+ r@ typeL r> 1+ xeven r> + >r
  161.                 1+ ;
  162.  
  163. : at."          ( x1 y1 | text --- x1 y1+1 )
  164.                 compile (at.") x," ; immediate
  165.  
  166. : showkeys      ( --- )                 \ show some help
  167.                 forgx forgy 17 -1 d+
  168.                 at." ┌────────────────┐"
  169.                 at." │ Hom │  │ PgUp │"
  170.                 at." │ ────┼───┼───── │"
  171.                 at." │ End │  │ PgDn │"
  172.                 at." ├────────────────┴─────────────────────┐"
  173.                 at." │ A-Z = Next file starting with Letter │"
  174.                 at." │ ─┘ = Select file or directory       │"
  175.                 at." │ Esc = Cancel file selection          │"
  176.                 at." │ Del = Delete selected file           │"
  177.                 at." │   \ = Type in a new Directory Spec.  │"
  178.                 at." └──────────────────────────────────────┘" 2drop ;
  179.  
  180. : pathbox       ( --- )
  181.                 forgx forgy 17 10 d+ 2dup 52 2 d+ box&fill
  182.                 ."  Path = " ;
  183.  
  184. : showpath      ( --- )
  185.                 pathbox forgx forgy 26 11 d+ at
  186.                 dirspec$ dup pathset 0=
  187.                 if      count type
  188.                 else    ." Can't read path" drop
  189.                 then    ;
  190.  
  191. headers
  192.  
  193. : showdir       ( --- )         \ display directory window
  194.                 savecursor
  195.                 forgx forgy 1- 2dup 15 dlen 1+ d+ box
  196.                 forgx 15 + forgy        at ." \r"
  197.                 forgx 15 + forgy dlen + at ." \r"
  198.                 dlen 0
  199.         do      forgx forgy 1 i d+ at i foff+ #fls >=
  200.                 if      i 0= if      ." ...No Files..."
  201.                              else    ."               " then
  202.                 else    curfl i foff+ =
  203.                         if      i =: dirrow
  204.                                 >attrib1 ." ■" i foff+ .nam ." ■"
  205.                                 >norm
  206.                         else             ."  " i foff+ .nam ."  "
  207.                         then
  208.                 then
  209.         loop    restcursor ;
  210.  
  211. : nfl           ( --- )         \ next file
  212.                 curfl #fls 1- 0MAX = if exit then
  213.                 curfl 1+ #fls 1- min 0MAX dup !> curfl
  214.                 dup #fls < swap dlen 1- - foff = and
  215.                 if      foff 1+ #fls 15 - 0MAX min !> foff
  216.                 then    ;
  217.  
  218. : pfl           ( --- )         \ previous file
  219.                 curfl 1- 0MAX dup !> curfl
  220.                 foff =
  221.                 if      foff 1- 0MAX !> foff
  222.                 then    ;
  223.  
  224. headerless
  225.  
  226. : ?lmatch       ( --- f1 )
  227.                 curfl >fadr 1+ c@l aletter c@ = ;
  228.  
  229. : gotofl        ( --- )
  230.                 flitem @ 0MAX
  231.                 curfl over >
  232.                 if      curfl swap do pfl loop
  233.                 else    curfl     ?do nfl loop
  234.                 then    ;
  235.  
  236. : 0fl           ( --- )         \ first file
  237.                 0 !> curfl
  238.                 0 !> foff ;
  239.  
  240. variable foffsave
  241. variable curflsave
  242.  
  243. : find_letter   ( c1 --- c1 )       \ search for a file starting with c1
  244.                 95 and dup aletter c! curfl >r
  245.                 curfl #fls 1- 0MAX =
  246.                 if      0fl
  247.                 else    nfl
  248.                 then
  249.                 begin   ?lmatch curfl #fls 1- 0MAX = or 0=
  250.                 while   nfl
  251.                 repeat  ?lmatch 0=
  252.                 if      0fl r@ 0
  253.                         ?do     ?lmatch ?leave nfl
  254.                         loop    ?lmatch
  255. \ 05/25/90 tjz  fix per Mike Christopher
  256.                         if  curflsave @ curfl - 1+ dlen >=
  257.                                 if
  258.                                      foff foffsave ! curfl curflsave !
  259.                                 then
  260.                         then
  261.                 else    foff foffsave ! curfl curflsave !
  262.                 then    ?lmatch 0= if beep then
  263.                 r>drop ;
  264.  
  265. : efl           ( --- )       \ goto end of file list
  266.                 begin nfl curfl #fls 1- 0MAX = until ;
  267.  
  268. headers
  269.                                 \ a1 = counted string address
  270. : >pathend      ( a1 --- a2 )   \ a2 = the address of the char beyond last \
  271.                 >pathend" drop ;
  272.  
  273. : >pathend-1    ( a1 --- a2 )
  274.                 dup c@ >r               \ save old length
  275.                 dup>r >pathend          \ find last backslash
  276.                 r@ - 2- 0MAX r@ c!     \ adjust to new count
  277.                 r@ >pathend             \ find previous backslash
  278.                 r> r> swap c! ;         \ restore old length
  279.  
  280. headerless
  281.  
  282. : delfl         ( --- )                   \ delete the current file
  283.         curfl >fadr dup>r 1- c@l dirattrib and
  284.         forgx forgy 19 11 d+ 2dup at 50 spaces at
  285.         if      ." Can't delete directory !\b\:10"
  286.         else    ." Delete \`" dirseg r@ dir>pad type ." \` <- Y/N [N] "
  287.                 cursor-on key cursor-off bl or 'y' =
  288.                 if      dirspec$ >pathend dirspec$ 1+ - dup dirhndl c!
  289.                         dirspec$ 1+ dirhndl 1+ rot cmove
  290.                         dirseg r@ dir>pad >r dirhndl count + r@ cmove
  291.                         r> dirhndl c+!
  292.                         dirhndl count + off
  293.                         dirhndl hdelete 5 =
  294.                         if      ."  Access denied !\b\:10"
  295.                         then
  296.                 then    curfl foff
  297.                         getdir
  298.                         !> foff !> curfl
  299.         then    r>drop showpath ;
  300.  
  301. : ndir          ( --- )             \ Enter a NEW directory spec
  302.                 forgx forgy 17 14 d+ at
  303.                 ." Edit the Directory Spec, and press Enter. ESC=Cancel"
  304.                 cursor-on pathbox
  305.                 on> autoclear
  306.                 >attrib1
  307.                 forgx forgy 26 11 d+ dirspec$ 41 lineeditor drop
  308.                 >norm
  309.                 forgx forgy 17 14 d+ at 52 spaces
  310.                 dirspec$ count + 1- c@ dup '\' = swap ':' = or
  311.                 if      defdirspec$ count >r dirspec$ count + r@ cmove
  312.                              r> dirspec$ c+!
  313.                 then    dirspec$ c@ 0=
  314.                 if      defdirspec$ dirspec$ over c@ 1+ cmove
  315.                 then    0 dirspec$ count + c!
  316.                 dirspec$ pathset drop
  317.                 cursor-off getdir showpath 0fl ;
  318.  
  319. : keytests      ( n1 --- )
  320.                 dup false = if  ( do nothing ) else
  321. ( up arrow )    dup   200 = over 56 = or if pfl             else
  322. ( down arrow )  dup   208 = over 50 = or if nfl             else
  323. ( PgUp )        dup   201 = over 57 = or if dlen 2/ 0 ?do pfl loop else
  324. ( PgDn )        dup   209 = over 51 = or if dlen 2/ 0 ?do nfl loop else
  325. ( \ )           dup    92 =              if ndir            else
  326. ( 0 to 9)         dup '0' '9' between over bl or
  327. ( A to Z)             'a' 'z' between or if find_letter     else
  328. ( Del )         dup   211 = over 46 = or if delfl           else
  329. ( Home )        dup   199 = over 55 = or if 0fl             else
  330. ( End )         dup   207 = over 49 = or if efl             else   beep
  331.                 then then then then then then then then then then
  332.                 drop ;
  333.  
  334. : ?setdir       ( c1 --- c2 f1 ) \ return bool false if new dir
  335.             curfl >fadr dup>r 1- c@l dirattrib and      \ are we on a DIR
  336.             #fls 0> and                                 \ and have anything
  337.             if    drop
  338.                   dirseg r@ dir>pad + off       \ move DIR to PAD, nul term
  339.                   pad 1+ @ rootdir @ =          \ is DIR the ROOT?
  340.                   if    dirspec$ 2+ c@ ':' =      \ include drive?
  341.                         if      '\' dirspec$ 3 + c! 3 dirspec$ c!
  342.                                 defdirspec$ count >r
  343.                                 dirspec$ count + r@ cmove r> dirspec$ c+!
  344.                         else    defdirspec$ dirspec$ over c@ 1+ cmove
  345.                         then    dirspec$ count + off  \ nul term
  346.                         begin   item# @ 1 >           \ Clear DIR stack
  347.                         while   istk> drop
  348.                         repeat  istk> setfl           \ set to ROOT
  349.                   else  pad 1+ @ " .." drop @ =       \ pop one level?
  350.                         if    \ Now we need to remove a Dir from DIRSPEC$.
  351.                               \ so step through DIRSPEC to next to the last
  352.                               \ directory.
  353.                               dirspec$ >pathend-1 dirspec$ 1+ - dirspec$ c!
  354.                               \ Append *.* to current directory specification
  355.                               defdirspec$ count >r dirspec$ count + r@ cmove
  356.                               r> dirspec$ c+!
  357.                               dirspec$ count + off    \ nul terminate
  358.                               istk> setfl             \ pop DIR stack
  359.  
  360.                         else  \ Must be on a directory name other than
  361.                               \ "." or ".." so step down to that directory
  362.  
  363.                               dirspec$ >pathend dup   \ set dirspec length
  364.                               dirspec$ 1+ - dirspec$ c!
  365.                                                       \ append DIR from PAD
  366.                                                       \ to dirspec
  367.                               pad count >r swap r@ cmove
  368.                               r> dirspec$ c+!         \ set length
  369.                               " \" >r dirspec$ count + r@ cmove \ append "\"
  370.                               r> dirspec$ c+!
  371.                               defdirspec$ count >r dirspec$ count + r@ cmove
  372.                               r> dirspec$ c+!         \ append *.*
  373.                               dirspec$ count + off    \ null terinate
  374.                               curfl >istk             \ save directory offset
  375.                               0 setfl                 \ reset offset to zero
  376.                         then
  377.                   then              \ get new directory, and show the path
  378.                   cursor-off getdir showpath gotofl
  379.                   false false
  380.             else  true
  381.             then  r>drop ;
  382.  
  383. headers
  384.  
  385. FORTH DEFINITIONS
  386.  
  387. : <getfile> ( --- <a1> f1 )   \ return a1 filename addr and boolean
  388.             rows forgy - 4 - =: dlen
  389.             dirseg 0= if false exit then  \ if it didn't work, then leave
  390.             ['] wflbutton save!> dobutton \ init mouse support
  391.             savecursor
  392.             savescr    \ save cursor and screen
  393.             forgx 2- forgy 2- over 74 + rows 3 - box&fill
  394.             forgx forgy 36 1 d+ at                 \ then my message
  395.             ." \r Tom's Window File Selection Tool "
  396.             forgx forgy 20 7 d+ at
  397.             ." \2 Reading Directory Files... "
  398.             cursor-off getdir        \ clear screen, and get dir
  399.             0fl showkeys showpath         \ show the keys and dir path
  400.             forgx forgy 17 16 d+ at               \ and som help information
  401.             ." Use  to pick a file, or press the first letter of"
  402.             forgx forgy 17 17 d+ at
  403.             ." the file you want, then press Return to select it."
  404.             begin   showdir 0 0 at        \ show the directory
  405.                   key dup 13 = dup        \ wait for a key, if Enter
  406.                   if      drop ?setdir ( c1 --- c2 f1 )     \ try to set dir
  407.                   then    over 27 = or 0= \ else check for escape or null
  408.             while   keytests        \ if neither then try to find a file
  409.             repeat  13 = dup        \ if it was Enter, then get the file name
  410.                                     \ we are on and move it to PAD. Prepend
  411.                                     \ the DIR spec.
  412.             if    dirspec$ >pathend dirspec$ 1+ - >r
  413.                   dirspec$ pad r@ 1+ cmove r> pad c!
  414.                   curfl >fadr 2dup c@l >r 1+
  415.                   ?cs: pad count + r@ cmovel r> pad c+!
  416.                   pad handle>ext c@ '.' <>      \ append '.' if no extension
  417.                   if    '.' pad count + c!
  418.                         1 pad c+!
  419.                   then  pad swap
  420.             then
  421.             restscr                     \ restore screen
  422.             restcursor                  \ restore cursor position
  423.             restore> dobutton
  424.             #fls 0=
  425.             if    dup
  426.                   if    2drop false     \ discard addr even if found if
  427.                                         \ no files in list
  428.                   then
  429.             then  dirseg_release ;      \ return boolean for file selected
  430.  
  431. ' <getfile> is getfile          \ patch in window get file.
  432.  
  433. behead
  434.  
  435.  
  436.