\ WFL.SEQ Window file selection. by Tom Zimmer ONLY FORTH ALSO HIDDEN DEFINITIONS ALSO create rootdir ascii . c, 0 c, \ root is . & null create itemstk 10 allot itemstk 10 erase variable item# item# off variable flitem flitem off : setfl ( n1 --- ) flitem ! ; : 0istk ( --- ) itemstk 10 erase item# off ; : >istk ( n1 --- ) item# @ itemstk + c! item# @ 1+ 9 min item# ! ; : istk> ( --- n1 ) item# @ 1- 0 max dup item# ! itemstk + dup c@ swap off ; create dirspec$ ," *.seq" b/hcb allot -1 dirspec$ >hndle ! dirspec$ count + off 14 constant b/fnam \ bytes per filename 500 constant maxdir b/fnam maxdir * 16 / 1+ constant #dirsegs 0 constant dirseg 1 constant forg \ top of file window display 23 constant dlen \ directory window length 16 constant dirattrib \ directory file attribute 0 constant #fls \ number of files present 0 constant curfl \ current file number 0 constant foff variable dirw1 \ only warn once variable aletter : dirreset ( --- ) \ Set directory segment to not defers initstuff \ yet initialized. 0 !> dirseg dirw1 off ; ' dirreset is initstuff : dirinit ( --- ) \ try to initialize the directory dirseg 0= \ buffer. if #dirsegs alloc 8 = if 2drop dirw1 @ 0= if cr beep ." No room for directory buffer!, " ." Can't pop up Dir window. Sorry!" cr dirw1 on 1 seconds then else nip =: dirseg then then ; : dirclear ( --- ) dirseg ?dup if dealloc drop 0 !> dirseg then ; code foff+ ( n1 --- n2 ) pop ax add ax, ' foff >body 1push end-code code >fadr ( name# -- seg name_offset ) pop ax mov bx, # b/fnam mul bx \ b/fnam * add ax, # 1 \ 1+ mov dx, ' dirseg >body \ dirseg 2push end-code : dir>pad ( seg off --- a1 n1 ) 2dup c@l >r ?cs: pad r@ 1+ cmovel pad 1+ r> ; : .nam ( n1 --- ) >fadr dup >r dir>pad dup >r type 12 r> - " " drop swap type \ a bunch of spaces dirseg r> 1- c@l dirattrib and if #out @ 1- #line @ at ." ì" then ; : name>buf ( --- ) \ move name from dta to buffer #fls >fadr nip >r pad 30 + 12 dup 0 do over i + c@ 0= if drop i leave then loop dup dirseg r@ c!l >r ?cs: swap dirseg r> r@ 1+ swap cmovel pad 21 + c@ dirseg r> 1- c!l ; : $getdir ( a1 --- ) dup pathset drop shndl+ $>handle \ get directory spec 0 !> curfl 0 !> foff 0 !> #fls pad SET-DTA shndl+ >nam findfirst begin 255 and 0= #fls maxdir > 0= and while name>buf incr> #fls findnext repeat ; : getdir ( --- ) dirspec$ $getdir ; create 196's 80 allot 196's 80 196 fill : -ss 196's swap type ; : -ll ( l r len line --- ) 17 swap forg + at rot FEMIT -ss FEMIT ; : showret ( --- ) 17 forg 4 + at 179 FEMIT space 17 FEMIT 196 FEMIT 217 FEMIT ." = Select file/directory " 179 FEMIT 17 forg 5 + at 179 FEMIT ." Esc = Cancel file selection " 179 FEMIT 17 forg 6 + at 179 FEMIT ." Del = Delete a file " 179 FEMIT 17 forg 7 + at 179 FEMIT ." \ = Enter a new Dir Spec. " 179 FEMIT 192 217 29 8 -ll ; : showkeys ( --- ) \ show some help 218 191 16 -1 -ll 17 forg at " Hom x PgUp " >r 179 over c! 179 over 6 + c! 24 over 8 + c! 179 over 10 + c! 179 over 17 + c! r> type 17 forg 1+ at 179 FEMIT space 4 -ss 197 FEMIT 3 -ss 197 FEMIT 5 -ss space 179 FEMIT 17 forg 2+ at " End x PgDn " >r 179 over c! 179 over 6 + c! 25 over 8 + c! 179 over 10 + c! 179 over 17 + c! r> type 195 193 16 3 -ll 12 -SS 191 FEMIT showret ; : pathbox ( --- ) 218 191 57 9 -ll 17 forg 10 + at 179 FEMIT ." Path = " >NORM space 179 FEMIT 192 217 57 11 -ll ; : showpath ( --- ) pathbox 26 forg 10 + at dirspec$ dup pathset 0= if count type else ." Can't read path" drop then ; : showdir ( --- ) \ display cirectory window #out @ #line @ >r >r 1 forg 1- at 218 FEMIT 14 -ss 191 FEMIT dlen 0 do 1 i forg + at i foff+ #fls >= 179 FEMIT if i 0= if ." ...No Files..." else ." " then else curfl i foff+ = if ( 221 ) 16 FEMIT i foff+ .nam ( 222 ) 17 FEMIT else bl FEMIT i foff+ .nam bl FEMIT then then 179 FEMIT loop 1 forg dlen + at 192 FEMIT 14 -ss 217 FEMIT r> r> at ; : nfl ( --- ) \ next file curfl #fls 1- 0 max = if exit then curfl 1+ #fls 1- min 0 max dup !> curfl dup #fls < swap dlen 1- - foff = and if foff 1+ #fls 15 - 0 max min !> foff then ; : pfl ( --- ) \ previous file curfl 1- 0 max dup !> curfl foff = if foff 1- 0 max !> foff then ; : ?lmatch ( --- f1 ) curfl >fadr 1+ c@l aletter c@ = ; : gotofl ( --- ) flitem @ 0 max curfl over > if curfl swap do pfl loop else curfl ?do nfl loop then ; : 0fl ( --- ) \ first file 0 !> curfl 0 !> foff ; variable foffsave variable curflsave : find_letter ( c1 --- c1 ) 95 and dup aletter c! curfl >r curfl #fls 1- 0 max = if 0fl else nfl then begin ?lmatch curfl #fls 1- 0 max = or 0= while nfl repeat ?lmatch 0= if 0fl r@ 0 ?do ?lmatch ?leave nfl loop ?lmatch if foffsave @ curflsave @ curfl - 1+ dlen >= if curfl then =: foff then else foff foffsave ! curfl curflsave ! then ?lmatch 0= if beep then r>drop ; : efl ( --- ) begin nfl curfl #fls 1- 0 max = until ; \ a1 = counted string address : >pathend ( a1 --- a2 ) \ a2 = the address of the char beyond last \ count begin 2dup ascii \ scan ?dup while 2swap 2drop 1 -1 d+ repeat 2drop ; : >pathend-1 ( a1 --- a2 ) dup c@ >r \ save old length dup >r >pathend \ find last backslash r@ - 2- 0 max r@ c! \ adjust to new count r@ >pathend \ find previous backslash r> r> swap c! ; \ restore old length : delfl ( --- ) curfl >fadr dup >r 1- c@l dirattrib and 19 forg 10 + 2dup at 55 spaces at if ." Can't delete directory !" beep 1 seconds else ." Delete '" dirseg r@ dir>pad type ." ' <- Y/N [N] " cursor-on key cursor-off bl or ascii y = if dirspec$ >pathend dirspec$ 1+ - dup shndl+ c! dirspec$ 1+ shndl+ 1+ rot cmove dirseg r@ dir>pad >r shndl+ count + r@ cmove r> shndl+ c+! shndl+ count + off shndl+ hdelete 5 = if ." Access denied !" beep 1 seconds then then curfl foff getdir !> foff !> curfl then r>drop showpath ; : ndir ( --- ) 18 forg 12 + at ." Edit the Directory Specification, and press Enter. ESC=Cancel" cursor-on pathbox 26 forg 10 + dirspec$ 48 lineedit 18 forg 12 + at 61 spaces dirspec$ count + 1- c@ dup ascii \ = swap ascii : = or if " *.*" dirspec$ count + swap cmove 3 dirspec$ c+! then dirspec$ c@ 0= if " *.*" ">$ dirspec$ over c@ 1+ cmove then 0 dirspec$ count + c! dirspec$ pathset drop cursor-off getdir showpath 0fl ; : keytests ( n1 --- ) dup false = if ( do nothing ) else ( up arrow ) dup 200 = over 56 = or if pfl else ( down arrow ) dup 208 = over 50 = or if nfl else ( PgUp ) dup 201 = over 57 = or if dlen 2/ 0 ?do pfl loop else ( PgDn ) dup 209 = over 51 = or if dlen 2/ 0 ?do nfl loop else ( \ ) dup 92 = if ndir else ( 0 to 9) dup ascii 0 ascii 9 between over bl or ( A to Z) ascii a ascii z between or if find_letter else ( Del ) dup 211 = over 46 = or if delfl else ( Home ) dup 199 = over 55 = or if 0fl else ( End ) dup 207 = over 49 = or if efl else beep then then then then then then then then then then drop ; : ?setdir ( c1 --- c2 f1 ) \ return bool false if new dir curfl >fadr dup >r 1- c@l dirattrib and if drop dirseg r@ dir>pad + off pad 1+ @ rootdir @ = if " \*.*" dirspec$ 2+ c@ ascii : = if >r dirspec$ 3 + r@ cmove r> 2+ dirspec$ c! else ">$ dirspec$ over c@ 1+ cmove then dirspec$ count + off begin item# @ 1 > while istk> drop repeat istk> setfl else pad 1+ @ " .." drop @ = \ pop one level? if dirspec$ >pathend-1 dup dirspec$ 1+ - dirspec$ c! " *.*" >r dirspec$ count + r@ cmove r> dirspec$ c+! dirspec$ count + off istk> setfl else dirspec$ >pathend dup dirspec$ 1+ - dirspec$ c! pad count >r swap r@ cmove r> dirspec$ c+! " \*.*" >r dirspec$ count + r@ cmove r> dirspec$ c+! dirspec$ count + off curfl >istk 0 setfl then then cursor-off getdir showpath gotofl false false else true then r>drop ; ONLY FORTH DEFINITIONS ALSO HIDDEN ALSO : ( --- f1 ) \ return a1 filename addr and dirinit dirseg 0= if false exit then #out @ #line @ >r >r savescr dark cursor-off getdir 0fl showkeys showpath 40 forg 1+ at >rev ." Tom's Window File Selection Tool " >norm 18 forg 14 + at ." Press the letter S to go to the next file starting with S," 21 forg 15 + at ." or the letter G to go to the next file starting with G ect." begin showdir 0 0 at key dup 13 = dup if drop ?setdir ( c1 --- c2 f1 ) then over 27 = or 0= while keytests repeat 13 = dup if dirspec$ >pathend dirspec$ 1+ - >r dirspec$ pad r@ 1+ cmove r> pad c! curfl >fadr 2dup c@l >r 1+ ?cs: pad count + r@ cmovel r> pad c+! pad swap then r> r> at restscr cursor-on dirclear #fls 0<> and ; ' is getfile \ patch in window get file.