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