( ( |-- | rUpdate | ( ./CoSy/Job.f : rUpdate lfMV s" .r" Dv@ JobHndlt_ settxt ; ( textListOrStr -- ) ) ) ( |-- | rShow | ( ./CoSy/Job.f : rShow ` .r Dv@ dup setWdo showWdo ; ) ) ( |-- | T0 | ( ./CoSy/CoSy.f : >T0> dup : >T0 R ` T0 v! ; : T0 R ` T0 v@ ; : >T1> dup : >T1 R ` T1 v! ; : T1 R ` T1 v@ ; ) ) ( |-- | >T0> | ( ./CoSy/CoSy.f ev >value t0 | Temp handle holder . Frees old value when assigned new : >t0> dup : >t0 ( ob -- ob ) t0 refs- refs+> to t0 ; ev >value t1 : >t1> dup : >t1 ( ob -- ob ) | Another Temp handle holder . t1 refs- refs+> to t1 ; ev >value t2 : >t2> dup : >t2 ( ob -- ob ) | Another Temp handle holder | 20200321 | t2 refs- refs+> to t2 ; ev >value t3 : >t3> dup : >t3 ( ob -- ob ) | Another Temp handle holder | 20200321 | t3 refs- refs+> to t3 ; : >T0> dup : >T0 R ` T0 v! ; : T0 R ` T0 v@ ; : >T1> dup : >T1 R ` T1 v! ; : T1 R ` T1 v@ ; ) ) ( |-- | R0 | ( ./CoSy/CoSy.f | Utility treed variable : >R0> dup : >R0 R ` R0 v! ; : R0 R ` R0 v@ ; : >R1> dup : >R1 R ` R1 v! ; : R1 R ` R1 v@ ; ) ) ( |-- | \/>F | ( ./CoSy/CoSy.f : F>/\ F> str>lst ; | io of lists directly | 20200831 : \/>F swap lst>str swap >F ; | fixed \/>F 20201230 ) ) ( |-- | F>/\ | ( ./CoSy/CoSy.f : F>/\ F> str>lst ; | io of lists directly | 20200831 : \/>F swap lst>str swap >F ; | fixed \/>F 20201230 ) ) ( |-- | DT>lst | ( ./CoSy/Furniture.f | Splits each of list of strings on commas which are not in quotes : ,svMsk >a> "msk 0=i a> ` , =c mini ; | mask of commas not in quotes | 20200421 | : ,sv>lst { >a> dup ,svMsk & 0cut ' dl, 'm a- } 'm ; | \/ | Example | \/ | | s" C:/CoSy/acnts/y17/CHK.CSV" F> >T0> -2 _take c>i |>| 13 10 | read in and check if line delimiter is "lf or "cr "lf , ie: "nl | which is generally the trailing element . Win uses "nl . most others "lf | T0 "nl "ht ,L csv>DT >T1 | splits on "nl then each on "ht | | Note the combining of the line and item delimiters by ' ,L | And the inverse : DT>lst 1p> dsc enc R@ 1 _at flip cL 1P> ; : lst>csv ( lst d0,d1 -- csv ) 2p> dsc ['] MV 'L R@ 1 _at MV 2P> ; : DT>csv ( DT d1,d0 -- csv ) 2p> --aba dnames swap MV 2P> ; | | Note that the delimiters have to be reversed . | T1 "nl "ht ,L reverse DT>csv | related | 20191006 | | executes lists of lines which produce lists , eg: ledger lists w lines like | (' 20190825.1322 _f ` lilBarn ` cash 200. _f s" Nate " ') | and flips them into column form : str>tbl ( strlst -- table ) dae ['] ^eval 'm flip ; ) ) ( |-- | csv>DT | ( ./CoSy/Furniture.f | I've used the term , abbreviated ' DT , in K.CoSy with a rather substantial | vocabulary . It is the fundamental form of a Kdb columnar data base . | A DT is a Dictionary whose first item is a list of column labels and second is | a corresponding set of correlated lists of values . This vocabulary converts | back and forth between CoSy DTs and standard .CSV strings , the most | universal format for bank ledger downloads . See 20171212 . : csv>lst ( csv d0,d1 -- lst ) 2p> dsc VM dae R@ 1 _at ['] VM 'L 2P> ; | Splits string first on d0 then each on d1 . | Example | t1 "nl "ht ,L csv>lst | see also 20180719 : lst>DT ( lst -- DT ) 1p> dsc R@ 1 _cut flip ,L 1P> ; : csv>DT ( csv d0,d1 -- DT ) csv>lst lst>DT ; ) ) ( |-- | fmtDT | ( ./CoSy/Furniture.f : ?pad 2p> # -1*i take R@ strmatch_ if L@ 2P> ;then L@ R@ cL 2P> ; | ( str suffix -- str ) append suffix , eg: "bl , iff not already suffixed . | ` asdf ` q ?pad |>| asdfq | ` asdf ` f ?pad |>| asdf | 20210719.2309 | | /\ \/ need to be fixed for empty lines | 20210727 | : bl?pad { "bl ?pad } 'm ; | pad each item ( str ) w blank if not already | : pad 1p> dup rho' ,/ ' maxi ./ ' fill 'L 1P> ; | pad each str to length of longest | format table , list of columns , w space btwn each col : fmttbl >r { ' fmt 'm blpad pad } 'm flip r> ' MV 'L ; | 20210621.2131 | : fmttblh "ht fmttbl ; : fmttblb "bl fmttbl ; : fmttbl| s" | " fmttbl ; | invert w s" | " . : fmtDT >a> dsc a> 1 _at ' cL 'd fmttblh ; | 20210330 | 20210621 | | format DictionaryTable | (' labels values ') ) ) ( |-- | fmttbl| | ( ./CoSy/Furniture.f : ?pad 2p> # -1*i take R@ strmatch_ if L@ 2P> ;then L@ R@ cL 2P> ; | ( str suffix -- str ) append suffix , eg: "bl , iff not already suffixed . | ` asdf ` q ?pad |>| asdfq | ` asdf ` f ?pad |>| asdf | 20210719.2309 | | /\ \/ need to be fixed for empty lines | 20210727 | : bl?pad { "bl ?pad } 'm ; | pad each item ( str ) w blank if not already | : pad 1p> dup rho' ,/ ' maxi ./ ' fill 'L 1P> ; | pad each str to length of longest | format table , list of columns , w space btwn each col : fmttbl >r { ' fmt 'm blpad pad } 'm flip r> ' MV 'L ; | 20210621.2131 | : fmttblh "ht fmttbl ; : fmttblb "bl fmttbl ; : fmttbl| s" | " fmttbl ; | invert w s" | " . : fmtDT >a> dsc a> 1 _at ' cL 'd fmttblh ; | 20210330 | 20210621 | | format DictionaryTable | (' labels values ') ) ) ( |-- | prt<=l | ( ./CoSy/Furniture.f : prt>f 2p> ss1st R@ rho +i L@ swap cut 2P> ; : prt>=f 2p> ss1st L@ swap cut 2P> ; : prt<=l 2p> ['] reverse on2 prt>=f reverse 2P> ; : prt ['] reverse on2 prt>f reverse 2P> ; | /\ | ) ) ( |-- | prt>=f | ( ./CoSy/Furniture.f : prt>f 2p> ss1st R@ rho +i L@ swap cut 2P> ; : prt>=f 2p> ss1st L@ swap cut 2P> ; : prt<=l 2p> ['] reverse on2 prt>=f reverse 2P> ; : prt ['] reverse on2 prt>f reverse 2P> ; | /\ | ) ) ( |-- | dlb | ( ./CoSy/Furniture.f | delete leading blanks . 20190430 | factored 20200104 | : dlc >_ >aux 1p> dup { aux@ <> } f?m cut auxdrop 1P> ; : dlb "bl dlc ; | delete leading blank : dl, ` , dlc ; | " comma . forced by lack of recursive { } | 20200421 : dtc >aux reverse aux> dlc reverse ; : dtb reverse dlb reverse ; | delete trailing blanks | 20190608 : dab "bl ssd ; | trivial , but I keep expecting it to exist | 20230203 | see also 20190713 : dlws 1p> dup { 32 > } f?m cut 1P> ; | Delete leading white space : trim ( str chr -- drop_last_if ) swap >a> -1 _at =c >_ a> swap if -1 _cut then ; | delete last char if match | 20190713 | . fixed 20191201 | ) ) ( |-- | in | ( ./CoSy/Furniture.f : inb ( lst tok -- lst ) 2p> rho { take R@ match } 'L ,/ 2P> ; | bool of lines starting w tok | see 20180729 : in 2p> --aab inb & at 2P> ; | lines starting w tok : ninb inb 0=i ; : nin 2p> --aab ninb & at 2P> ; | the obvious complements ) ) ( |-- | str>f | ( ./CoSy/Furniture.f | Convert string to float . | moved from CoSy.f : str>f { >>fl if _f ;then z" not number " throw } onvan ; | 20211111 | | : str>f0 >a> i# 0if a- f0. ;then a> { >>fl if _f ;then f0. } onvan ; | 20230825 | returns 0.0 rather than aborts on non-number , specifically empty or blank string . ) ) ( |-- | m/d/y>ts | ( ./CoSy/Furniture.f : m/d/y>ts ` / "bl ,L ssr Eval --bac dtpk _i ; | 20200315 | convert datestamp ) ) ( |-- | F> | ( ( ./CoSy/Furniture.f | \/ | THESE ARE THE MAIN FILE R<>W VERBS | \/ | : >F : Foverwrite ( str flnm ) over van --abca van foverwrite 2ref0del ; : F> ( str -- str ) >r> van slurp r> ref0del --aab str swap nakedfree ; | Like "slurp" but takes and returns CoSy strings and frees original . | /\ | | /\ | ) ( ./lib/math/floats needs math/doubles needs string/justify ~doubles ~floats #10 constant b/float : floats b/float * ; : fldcw inline{ 50 d9 2c 24 58 } drop ; : fstcw dup inline{ 50 9b d9 3c 24 58 } ; : (round) fstcw %001111111111 and or fldcw ; : round.trunc %110000000000 (round) ; : round.even %000000000000 (round) ; : round.down %010000000000 (round) ; : round.up %100000000000 (round) ; | initialize to: truncate, high precision, no interrupts : finit ( -- ) inline{ 9b db e3 } %0000111100111111 fldcw ; : fcompp inline{ de d9 } ;inline : fstsw dup inline{ 9b df e0 } ;inline : fxam ( -- ) inline{ d9 e5 } ;inline : fneg? fxam fstsw %1000000000 and ; : f+ ( f:a f:b -- f:a+b ) inline{ de c1 } ;inline : f- ( f:a f:b -- f:a-b ) inline{ de e9 } ;inline : f* ( f:a f:b -- f:a*b ) inline{ de c9 } ;inline : f/ ( f:a f:b -- f:a/b ) inline{ de f9 } ;inline : fswap ( f:a f:b -- f:b f:a ) inline{ d9 c9 } ;inline : fsin ( f:a -- f:sin[a]) inline{ d9 fe } ;inline : fcos ( f:a -- f:cos[a]) inline{ d9 ff } ;inline : ftan ( f:a -- f:tan[a]) inline{ d9 f2 } ;inline : fnegate ( f:a -- f:-a ) inline{ d9 e0 } ;inline : f0 ( -- f:0.0 ) inline{ d9 ee } ;inline : f1 ( -- f:0.0 ) inline{ d9 e8 } ;inline : fatan2 ( f: y f: x -- f:atan[y/x]) inline{ d9 f3 } ;inline : fatan ( f: a -- f:atan[a]) f1 fatan2 ;inline : fsqrt ( f: a -- f:sqr[a] ) inline{ d9 fa } ;inline : fpi ( -- f:0.0 ) inline{ d9 eb } ;inline : fdup ( f:a -- f:a f:a ) inline{ d9 c0 } ;inline : fover ( f:a f:b -- f:a f:b f:a ) inline{ d9 c1 } ;inline : fdrop ( f:a f:b -- f:a ) inline{ dd d8 } ;inline | : fnip fswap fdrop ; : fnip inline{ dd d9 } ; | fstp st1 -- thanks, Bob! : fabs ( f:a -- f:a ) inline{ d9 e1 } ;inline : frot ( f:a f:b f:c -- f:b f:c f:a ) inline{ d9 c9 d9 ca } ;inline : f*/ ( f:a f:b f:c -- f:[a*b]/c ) frot frot f* fswap f/ ; | asin(x) = atan(x/sqrt(1 - sqr(x)) : fasin ( f: a -- f:asin[a]) fdup | a a fdup f* | a a^2 fnegate f1 f+ | a (1-x^2) fsqrt f/ fatan ; | acos(x) = atan(sqrt(1 - sqr(x))/x) : facos fdup | a a fdup f* | a a^2 fnegate f1 f+ | a 1-a^2 fsqrt fswap f/ fatan ; forth : s>f ( n -- f:a ) inline{ 50 db 04 24 58 } drop ; : d>f inline{ 50 ff 36 df 2c 24 5b 5b } 2drop ; : f! ( addr f:a -- ) inline{ db 38 } drop ; : f@ ( addr -- f:a ) inline{ db 28 } drop ; : f!4 ( addr4 f:a -- ) inline{ d9 18 } drop ; : f@4 ( addr4 -- f:a ) inline{ d9 00 } drop ; : f!8 ( addr8 f:a -- ) inline{ dd 18 } drop ; : f@8 ( addr8 -- f:a ) inline{ dd 00 } drop ; : f>32 inline{ 8d 76 fc d9 1e 87 06 } ; | Put 32 bit IEEE of TOFS on integer stack : f>64 inline{ 8d 76 f8 dd 1e 87 46 04 } ; | Put 64 bit IEEE of TOFS on integer stack : (fcmp) fcompp fstsw $4500 and ; : f= ( f:a f:b -- flag ) (fcmp) $4000 = ; : f> ( f:a f:b -- flag ) (fcmp) $0100 = ; : f< ( f:a f:b -- flag ) (fcmp) not ; : ffloor fstcw round.down inline{ d9 fc } fldcw ; : fint fstcw round.trunc inline{ d9 fc } fldcw ; : fround fstcw round.even inline{ d9 fc } fldcw ; | added BA 20230524 : ffrac ( f:a -- f:a ) fabs fdup fint f- ; : f>s ( f:a -- n ) fround dup inline{ 50 db 1c 24 58 } ; | changed from ` ffloor BA 20230524 : f>d ( f:a -- d ) ffloor 2dup inline{ 50 50 df 3c 24 8f 06 58 } ; : frac>dec ( num den -- f:x ) swap s>f s>f f/ ; | new, 7.0.5: : 1/f inline{ d9 e8 de f1 } ;inline | fld1 fdivrp : f/2 inline{ D9 E8 D8 C0 D9 C9 DE F1 } ; | fld1; fadd st,st; fxch; fdivrp : fcosec | ( F: f -- cosec(f) ) fsin 1/f ; : fsec | F: f -- sec(f) fcos 1/f ; : fcotan | f: f -- cot(f) ftan 1/f ; : fln | F: f -- ln(f) | Floating point log base e. | fldln2; fxch; fyl2x inline{ D9 ED D9 C9 D9 F1 } ; : f2^ inline{ D9 C0 D9 FC DC E9 D9 C9 D9 F0 D9 E8 DE C1 D9 FD DD D9 } ; : f^ | f: y x -- x^y inline{ D9 F1 } f2^ ; ) ) ) ( |-- | #' | ( ./CoSy/Furniture.f : #' : rho' ['] rho 'm ; | rho on each item of list . for convenience | #' 20200704 ) ) ( |-- | blMV | ( ./CoSy/Furniture.f | Matrix to Vector . Ravels , eg : lists of strings LA inserting token RA | , eg : "bl or "lf , as a delimiter | in K | { ( # x ) _ ,/ x ,/: y } : MV over Type@ 0if 2p R@ L@ ['] cL 'R ,/ R@ rho cut 2P> ;then drop ; | Just returns simples so no bomb | 20190510 | : lfMV "lf MV ; : nlMV "nl MV ; : blMV "bl MV ; | for symmetry w VM fns ) ) ( |-- | dsel | ( ./CoSy/CoSy.f : dsel ( dic syms -- dic ) | returns dic of items named in list syms . 2p R@ R@ { L@ swap v@ } eachM> ,L 2P> ; ) ) ( |-- | v@ | ( ./CoSy/CoSy.f | fetch value associated with symbol in dictionary : .v@ ( dic sym -- val ) vx_ undefthrow @ ; : v@ ( D idx -- val ) blVM ' .v@ Y./ ; | eg: | R `( a b c )` v@ | changed from ' encatom 20230512 | if I were smarter , maybe I'd use | prior v@ | . need to play w first . ) ) ( |-- | con | ( ./CoSy/CoSy.f | : cconb ( strings str -- bool ) | returns bool where stings in LA contain RA | 2refs+> 2dup ['] ssc eachleft { i# sn _i } eachM> ,/ --cab 2refs- ; : cconn ( strings str -- idxs ) | returns indexs of stings in LA containing RA cconb & ; : ccon ( strings str -- strings ) | returns stings in LA containing RA 2p L@ dup R@ cconn at\ 2P> ; : ncconn cconb 0=i & ; : conb ( strings str -- bool ) 2p L@ ['] lower eachM> R@ lower cconb 2P> ; : conn ( strings str -- idxs ) | case insensitive conn conb & ; : nconn conb 0=i & ; : con ( strings str -- strings ) | returns stings in LA containing RA 2p L@ dup R@ conn at\ 2P> ; : ncon 2p L@ dup R@ nconn at\ 2P> ; ) ) ( |-- | flip | ( ./CoSy/CoSy.f : flip ( CSob -- CSob ) | Transpose list of 2 lists . | returns list of each item of 0th list w corresponding item of 1st subject | to the minimum length of the 2 lists . | dup @ if ;then | transpose of a simple obj is itself dup i# 0;drop | same for empty refs+> dup ' # 'm ,/ ' mini ./ >_ cellVecInit >aux> | ob new i# 0 ?do dup i _nth refs+> aux@ i i! loop refs- aux> ; ) ) ( |-- | enc' | ( ./CoSy/CoSy.f : enc' ['] enc eachm ; | enc each ( 'm bombs on floats ) ) ) ( |-- | ssd | ( ./CoSy/CoSy.f | ' ssr replaces occurences in str of s0 with s1 . ' ssd deletes . : ssd ec ,L : ssr ( str s0 s1 ,L -- str ) | 20190326 2p L@ R@ 0 i@ toksplt dup i# 1 =if refs- L@ 2P> ;then R@ 1 i@ ['] cL eachleft ,/ R@ 1 i@ rho -1*i cut 2P> ; ) ) ( |-- | lfVM | ( ./CoSy/CoSy.f | moved from \Furniture.f 20230512 to be defined earlier , before , eg: ' v@ : VM --aba Type@ TypeC =if toksplt ;then ref0del ; | 20230604 | made to simply return non-strings , ie: already nested . | 20200826 | was bad idea deleted 20201223.0025 | added ' dae because bunch of words don't like empties . | name from APL " Vector to Matrix " | updated to call ' VM rather than ' toksplt : blVM "bl VM ; : nlVM ( str -- list_of_strings_split_on_crlf ) "nl VM ; | Vector to Matrix on "newlines" . : lfVM ( str -- list_of_strings_split_on_cr ) "lf VM ; : htVM ( str -- list_of_strings_split_on_tab ) "ht VM ; ) ) ( |-- | ,/ | ( ./CoSy/CoSy.f : cL local[ l0 l1 | n0 n1 adr -- adr ] | catinate Lists . keeps matching simple simple . l0 @ l1 @ or if l0 @ l1 @ =if | both same simple l0 @ _n =if ." nil " cr ,L ;then | nil is special . | l0 @ TypeS =if l0 l1 ,L ;then l0 l1 cLsimple ;then then l0 ?enc if l0 i# else 1 then to n0 l1 ?enc if l1 i# else 1 then to n1 n0 n1 + cellVecInit to adr l0 ?enc if l0 i# 0 ?do l0 i i@ refs+> adr i i! loop else l0 refs+> adr 0 i! then l1 ?enc if l1 i# 0 ?do l1 i i@ refs+> adr n0 i + i! loop else l1 refs+> adr n0 i! then | l0 l1 n0 n1 $.s 2drop 2drop | debugging l0 ref0del l0 l1 <>if l1 ref0del then adr ; : ,/ ( lst -- lst ) | discloses each item of lst . just returns simple dup Type@ if ;then ['] cL across ; ) ) ( |-- | cL | ( ./CoSy/CoSy.f : cL local[ l0 l1 | n0 n1 adr -- adr ] | catinate Lists . keeps matching simple simple . l0 @ l1 @ or if l0 @ l1 @ =if | both same simple l0 @ _n =if ." nil " cr ,L ;then | nil is special . | l0 @ TypeS =if l0 l1 ,L ;then l0 l1 cLsimple ;then then l0 ?enc if l0 i# else 1 then to n0 l1 ?enc if l1 i# else 1 then to n1 n0 n1 + cellVecInit to adr l0 ?enc if l0 i# 0 ?do l0 i i@ refs+> adr i i! loop else l0 refs+> adr 0 i! then l1 ?enc if l1 i# 0 ?do l1 i i@ refs+> adr n0 i + i! loop else l1 refs+> adr n0 i! then | l0 l1 n0 n1 $.s 2drop 2drop | debugging l0 ref0del l0 l1 <>if l1 ref0del then adr ; : ,/ ( lst -- lst ) | discloses each item of lst . just returns simple dup Type@ if ;then ['] cL across ; ) ) ( |-- | ,L | ( ./CoSy/CoSy.f : ,L ( O0 O1 -- O2 ) | most basic catination of objects . Lisp like 2 cellVecInit dup vbody dup 4 pick refs+> swap ! 2 pick refs+> swap cell+ ! nip nip ; ) ) ( |-- | reverse | ( ./CoSy/CoSy.f : reverse ( v -- r ) | 0 1 2 3 -> 3 2 1 0 dup v#@ VecInit | v r dup @ if ( SIMPLE ) dup i# over @ TypeFl =if 0 ?do over i 1+ negate i@ dup i i! loop else 0 ?do over i 1+ negate i@ over i i! loop then else ( LIST ) dup i# 0 ?do over i 1+ negate i@ refs+> over i i! loop then swap ref0del ; ) ) ( |-- | ') | ( ./CoSy/CoSy.f : (' _n ; : ') s_n>ev ; | make list of executed items . see 20180420 | eg: | (' 20180406.0724 _f ` PSBT ` BH 165.54 _f s" auto" ') | Compiles fine | 20190818 | ) ) ( |-- | (' | ( ./CoSy/CoSy.f : (' _n ; : ') s_n>ev ; | make list of executed items . see 20180420 | eg: | (' 20180406.0724 _f ` PSBT ` BH 165.54 _f s" auto" ') | Compiles fine | 20190818 | ) ) ( |-- | +\ | ( ./CoSy/CoSy.f : +\ dup Type@ TypeI =if ' + scanI ;then ' f+ scanf ; | need | 20200228 ) ) ( |-- | +/ | ( ./CoSy/CoSy.f : +/ ( RA -- r ) dup Type@ case Type0 of drop refs- z" ( nonce ) " throw endof TypeI of ['] + acrossI endof TypeFl of ['] f+ acrossf endof drop refs- z" invalid type " throw endcase ; ) ) ( |-- | 'm | ( ./CoSy/CoSy.f : 'm : eachM> ( RA fn -- R ) | each monadic | over TypeFl =if eachMfr ;then | Floating , sui generis | commented out | 20201123 over i# over fntype VecInit >lpstk | RA fn over refs+ lpstk@ i# 0 ?do over i _at over execute lpstk@ i i! loop lpstk@ v?refs+ drop refs- lpstk> ; ) ) ( |-- | at! | ( ./CoSy/CoSy.f : _at! _i : at! ( v0 v i -- ) | insert elements of v0 at locations i in v | NB : This will change v in the dictionary in which it is defined | If you want a new copy use ` duplst first . | dup i# 0if --bac 2refs- drop ;then | simply return if empty index swap >aux 2p | debugging ( L@ lst cr R@ lst cr aux@ lst cr ) aux@ Type@ 0if L@ i# 0do L@ i i@ aux@ R@ i i@ ix rplc loop 2P auxdrop ;then R@ i# 0do L@ i i@ aux@ R@ i i@ i! loop 2P auxdrop ; ) ) ( |-- | _at! | ( ./CoSy/CoSy.f : _at! _i : at! ( v0 v i -- ) | insert elements of v0 at locations i in v | NB : This will change v in the dictionary in which it is defined | If you want a new copy use ` duplst first . | dup i# 0if --bac 2refs- drop ;then | simply return if empty index swap >aux 2p | debugging ( L@ lst cr R@ lst cr aux@ lst cr ) aux@ Type@ 0if L@ i# 0do L@ i i@ aux@ R@ i i@ ix rplc loop 2P auxdrop ;then R@ i# 0do L@ i i@ aux@ R@ i i@ i! loop 2P auxdrop ; ) ) ( |-- | at | ( ./CoSy/CoSy.f : 1th 1 : _at _i : at ( v i -- v ) | discloses if singlton index . | no diference on simples . Try | Dnames 1 _at\ | vs | Dnames 1 _at | dup i# >r at\ r> 1 =if dsc then ; | 20210331 | added ` 1th as complement to dsc ) ) ( |-- | _at | ( ./CoSy/CoSy.f : 1th 1 : _at _i : at ( v i -- v ) | discloses if singlton index . | no diference on simples . Try | Dnames 1 _at\ | vs | Dnames 1 _at | dup i# >r at\ r> 1 =if dsc then ; | 20210331 | added ` 1th as complement to dsc ) ) ( |-- | 1th | ( ./CoSy/CoSy.f : 1th 1 : _at _i : at ( v i -- v ) | discloses if singlton index . | no diference on simples . Try | Dnames 1 _at\ | vs | Dnames 1 _at | dup i# >r at\ r> 1 =if dsc then ; | 20210331 | added ` 1th as complement to dsc ) ) ( |-- | dsc | ( ./CoSy/CoSy.f : dsc ( obj -- first_item ) | returns 0th item , | 20130923.230527 dup i# 0if ;then | If empty , just return dup @ 0if dup 0 i@ refs+> ( to protect result from freeing if nested ) swap ref0del dup refs-ok ;then 1 over @ VecInit >aux dup 0 i@ aux@ 0 i! ref0del aux> ; | otherwise , just returns . 20090809.1347 ) ) ( |-- | _iota | ( ./CoSy/CoSy.f | APL's iota on naked n . Returns 1st n integers . 0 is the 1st integer . : _iota ( n -- adr ) dup intVecInit dup vbody rot | adr bodyadr n 0 ?do i over i c+ ! loop drop ; ) ) ( |-- | _f | ( ./CoSy/CoSy.f : if@ ix f@ ; : if! ix f! ; | index fetch & store , float : _f : _fv ( float -- fv ) 1 floatVecInit >r> 0 if! r> ; | : 2_f _f _f swap ; ) ) ( |-- | `( | ( ./CoSy/CoSy.f macro | returns next word in input as a non-blank string | 20190304 | actually got working 20200212 | | Decided to name ` qua for ` as | 20220228 | : ]`[ parsews compiling? if (") ;then "" ; : ` p: ]`[ p: _str ; : `( | input non-blank strings up til " )`" -- vecOfSyms | 10 K* dup cellVecInit swap 0do parsews 2dup " )`" cmp if _str refs+> over i ic! else 2drop i Vresize leave then loop compiling? if refs+> literal, then ; forth ) ) ( |-- | ` | ( ( ./CoSy/CoSy.f macro | returns next word in input as a non-blank string | 20190304 | actually got working 20200212 | | Decided to name ` qua for ` as | 20220228 | : ]`[ parsews compiling? if (") ;then "" ; : ` p: ]`[ p: _str ; : `( | input non-blank strings up til " )`" -- vecOfSyms | 10 K* dup cellVecInit swap 0do parsews 2dup " )`" cmp if _str refs+> over i ic! else 2drop i Vresize leave then loop compiling? if refs+> literal, then ; forth : `D@ ( -- val ) p: ` Dv@ ; | Useful ? 20190326 20220613 ) ( ./CoSy/Furniture.f : `_ p: ` "bl cL ; | append blank to make true blank delimited word . : `__ p: ` "bl cL "bl swap cL ; | append leading and trailing blanks | 20200621 ) ) ) ( |-- | "lf | ( ) ) ( |-- | "bl | ( ./CoSy/Furniture.f | Matrix to Vector . Ravels , eg : lists of strings LA inserting token RA | , eg : "bl or "lf , as a delimiter | in K | { ( # x ) _ ,/ x ,/: y } : MV over Type@ 0if 2p R@ L@ ['] cL 'R ,/ R@ rho cut 2P> ;then drop ; | Just returns simples so no bomb | 20190510 | : lfMV "lf MV ; : nlMV "nl MV ; : blMV "bl MV ; | for symmetry w VM fns : ?pad 2p> # -1*i take R@ strmatch_ if L@ 2P> ;then L@ R@ cL 2P> ; | ( str suffix -- str ) append suffix , eg: "bl , iff not already suffixed . | ` asdf ` q ?pad |>| asdfq | ` asdf ` f ?pad |>| asdf | 20210719.2309 | | /\ \/ need to be fixed for empty lines | 20210727 | : bl?pad { "bl ?pad } 'm ; | pad each item ( str ) w blank if not already | : pad 1p> dup rho' ,/ ' maxi ./ ' fill 'L 1P> ; | pad each str to length of longest | format table , list of columns , w space btwn each col : fmttbl >r { ' fmt 'm blpad pad } 'm flip r> ' MV 'L ; | 20210621.2131 | : fmttblh "ht fmttbl ; : fmttblb "bl fmttbl ; : fmttbl| s" | " fmttbl ; | invert w s" | " . : fmtDT >a> dsc a> 1 _at ' cL 'd fmttblh ; | 20210330 | 20210621 | | format DictionaryTable | (' labels values ') ) ) ( |-- | ec | ( ) ) ( |-- | s" | ( ./CoSy/CoSy.f macro : "_ '" parse compiling? if (") ;then "" ; | 20180306 : s" p: "_ p: _str ; | like Reva ' " but no escape . : s/" p: " p: _str ; | like Reva ' " . | NOT ANS s" I didn't know about . forth ) ) ( |-- | i( | ( ./CoSy/CoSy.f macro : i( | input integers up til " )i" -- IV | 100 K* dup intVecInit swap 0do parsews >single if over i ic! else " )i" cmp if free z" integer input error" throw then | i/o error i Vresize leave then loop ; : `i ( -- int ) parsews >single if _i ;then | changed name from ` i^ | 20220615 2drop z" not integer" throw ; forth ) ) ( |-- | >t1> | ( ./CoSy/CoSy.f ev >value t0 | Temp handle holder . Frees old value when assigned new : >t0> dup : >t0 ( ob -- ob ) t0 refs- refs+> to t0 ; ev >value t1 : >t1> dup : >t1 ( ob -- ob ) | Another Temp handle holder . t1 refs- refs+> to t1 ; ev >value t2 : >t2> dup : >t2 ( ob -- ob ) | Another Temp handle holder | 20200321 | t2 refs- refs+> to t2 ; ev >value t3 : >t3> dup : >t3 ( ob -- ob ) | Another Temp handle holder | 20200321 | t3 refs- refs+> to t3 ; : >T0> dup : >T0 R ` T0 v! ; : T0 R ` T0 v@ ; : >T1> dup : >T1 R ` T1 v! ; : T1 R ` T1 v@ ; ) ) ( |-- | t1 | ( ./CoSy/CoSy.f : >T0> dup : >T0 R ` T0 v! ; : T0 R ` T0 v@ ; : >T1> dup : >T1 R ` T1 v! ; : T1 R ` T1 v@ ; ) ) ( |-- | >t0> | ( ./CoSy/CoSy.f ev >value t0 | Temp handle holder . Frees old value when assigned new : >t0> dup : >t0 ( ob -- ob ) t0 refs- refs+> to t0 ; ev >value t1 : >t1> dup : >t1 ( ob -- ob ) | Another Temp handle holder . t1 refs- refs+> to t1 ; ev >value t2 : >t2> dup : >t2 ( ob -- ob ) | Another Temp handle holder | 20200321 | t2 refs- refs+> to t2 ; ev >value t3 : >t3> dup : >t3 ( ob -- ob ) | Another Temp handle holder | 20200321 | t3 refs- refs+> to t3 ; : >T0> dup : >T0 R ` T0 v! ; : T0 R ` T0 v@ ; : >T1> dup : >T1 R ` T1 v! ; : T1 R ` T1 v@ ; ) ) ( |-- | t0 | ( ./CoSy/CoSy.f : >T0> dup : >T0 R ` T0 v! ; : T0 R ` T0 v@ ; : >T1> dup : >T1 R ` T1 v! ; : T1 R ` T1 v@ ; ) ) ( |-- | 2P | ( ./CoSy/ParameterPushing.f : 2p ( LA RA -- ) | pushs 2 args from stack to param stack | and ref incs . Use on entrance to 2 arg fn . SF+ LR@ 2refs+ ; : 2p> ( LA RA -- LA RA ) | pushs 2 args from stack to param stack | and ref incs . Use on entrance to 2 arg fn . SF+ LR@ 2refs+> ; : 2P ( -- ) | decrements refs and clears param stack . Use leaving 2 arg fn . RA 2@ 2refs- 2 SF- ; : 2P_> >aux 2P aux> ; : 2P> >aux+> 2P aux-ok> ; ) ) ( |-- | 2p> | ( ./CoSy/ParameterPushing.f : 2p ( LA RA -- ) | pushs 2 args from stack to param stack | and ref incs . Use on entrance to 2 arg fn . SF+ LR@ 2refs+ ; : 2p> ( LA RA -- LA RA ) | pushs 2 args from stack to param stack | and ref incs . Use on entrance to 2 arg fn . SF+ LR@ 2refs+> ; : 2P ( -- ) | decrements refs and clears param stack . Use leaving 2 arg fn . RA 2@ 2refs- 2 SF- ; : 2P_> >aux 2P aux> ; : 2P> >aux+> 2P aux-ok> ; ) ) ( |-- | L@ | ( ./CoSy/ParameterPushing.f : RA 1 SFx ; : LA 2 SFx ; | Shorthand for dyadic fns . : R@ 1 SF@ ; : L@ 2 SF@ ; : R! 1 SF! ; : L! 2 SF! ; : LR@ 2 SF@ 1 SF@ ; ) ) ( |-- | R@ | ( ( ./CoSy/ParameterPushing.f : RA 1 SFx ; : LA 2 SFx ; | Shorthand for dyadic fns . : R@ 1 SF@ ; : L@ 2 SF@ ; : R! 1 SF! ; : L! 2 SF! ; : LR@ 2 SF@ 1 SF@ ; ) ( ./src/reva.f : body> inline{ 8d 40 fb } ;inline : 2cell- inline{ 8d 40 f8 } ;inline : 2cell+ inline{ 8d 40 08 } ;inline : 3cell+ inline{ 8d 40 0c } ;inline : 4cell+ inline{ 8d 40 10 } ;inline : rot inline{ 50 8B 46 04 8B 1E 89 5E 04 8F 06 } ; : -rot inline{ 50 8B 5E 04 8B 06 89 1E 8F 46 04 } ; : c@ inline{ 0f b6 00 } ;inline | movzx eax, byte [eax] : nip inline{ 8d 76 4 } ;inline | lea esi, [esi+4] : pick inline{ 8b 04 86 } ;inline | mov eax, [esi+4*eax] : put inline{ 89 c3 ad 89 04 9e ad } ;inline | mov ebx, eax; lodsd ; mov [esi+4*ebx], eax ; lodsd : r> dup inline{ 58 } ;inline | [ $58 1, ; : r@ r> inline{ 50 } ;inline | [ $50 1, ; : >r inline{ 50 ad } ;inline | [ $ad50 2, ; : rdrop inline{ 5b } ;inline | [ $5b 1, ; : 00; inline{ 09 c0 75 01 c3 } ;inline | or eax, eax; jnz .done; ret; .done: : abs inline{ 99 31 d0 29 d0 } ;inline | cdq; xor eax, eax; sub eax, edx : (execute) inline{ ad ff d3 } ;inline | lodsd; call ebx : @execute inline{ 8b 18 } (execute) ;inline | mov ebx, [eax] : execute inline{ 89 c3 } (execute) ;inline | mov ebx, eax : exec ( dict -- ) inline{ 8D 58 FC 8B 1B 8B 40 04 FF E3 } ; : rp@ dup inline{ 89 e0 } ;inline | get current ESP : rpick inline{ 8b 04 84 } ;inline | mov eax, [4*eax+esp] : 2* inline{ d1 e0 } ;inline : 2/ inline{ d1 f8 } ;inline forth ) ) ) ( |-- | Eval | ( ( ./CoSy/CoSy.f : Eval : ^eval ( .. str -- ? ) >r> van eval r> ref0del ; | depricating ` ^eval | 20200228 | evaluates a CoSy string which can , of course , take & put args on the stk . ) ( ./CoSy/util.f | macro | : x" p[ " 2dup type ]p ." | " p: eval ; | forth |/\| Debugging & tracing fns |/\| ) ) ) ( |-- | # | ( ./CoSy/CoSy.f : # : rho ( list -- #L ) dup i# _i swap ref0del ; | Same as i# but CoSy list result ) ) ( |-- | enc | ( ./CoSy/CoSy.f : enc ( CSob -- CSob ) | enclose 1 cellVecInit swap refs+> over vbody ! ; : encatom ( CSob -- CSob ) | Enclose iff not enclosed . dup @ if enc then ; | An atom is anything other than a general list . : enc>1 ( CSob -- CSob ) | Enclose iff i# > 1 dup i# 1 <>if enc then ; ) ) ( |-- | Type | ( ./CoSy/CoSy.f | Basic header info . Does not effect object . : Type @ _i ; | Return Type , content of first cell , as a list | 20200510 | ! : Count i# _i ; | Return Type , content of 2nd cell , as a list | 20200603 | ! : Ref# refs@ _i ; | Return Reference Count 3rd item ; currently half cell | 20200603 ) ) ( |-- | _i | ( ./CoSy/CoSy.f : _i ( cell -- 1_item_intvec ) 1 intVecInit >r> 0 ii! r> ; : 2_i ( i i -- iv iv ) _i swap _i swap ; ) ) ( |-- | ' | ( ( ./CoSy/CoSy.f : under ( ... f g -- g f g on stk ) 2>aux auxx@ xeq aux> xeq aux> xeq ; | execute ' f ` under to use ` Js term , ' g . see eg: ' dtb | 20190713 : _.\ : scan | result returning "\" | changed name to indicate ` raw over i# 0=I z" nonce : empty , needs prototype " * throw over Type@ TypeFl =if scanf ;then | Must be raw float fn . eg: ' f+ over refs+> i# over fntype VecInit >lpstk over 0 i@ lpstk@ 0 i! over i# 1 ?do lpstk@ i 1- i@ 2 pick i i@ 2 pick execute lpstk@ i i! loop drop refs- lpstk> ; : _f? ( lst RA boolF -- index | _n ) | index of first item in LA on which { RA boolF } | returns true . Returns _n if not found . | This is a generalization of APL's dyadic iota , and | K's ? both of which are functions which assume the boolF : ' = | >lpstk 2refs+> over i# 0 ?do over i i@ over lpstk@ execute if lpstkdrop 2refs- i unloop ;then loop lpstkdrop 2refs- _n ; : f? ( lst RA boolF -- index ) | index of first item in LA on which { RA boolF } | returns true . Returns LA rho ( bad idea : Returns _n ) if not found . | This is a generalization of APL's dyadic iota , and | K's ? both of which are functions which assume the boolF : ' = | >lpstk 2p L@ i# 0 ?do L@ i _at R@ lpstk@ execute >_ if lpstkdrop 2P i _i unloop ;then loop lpstkdrop L@ rho 2P> ; : f?m ( lst rawBoolF -- index ) | index of first item in RA on which ' boolF | returns true . Returns RA rho if not found . | This is a generalization of APL's dyadic iota , and | K's ? both of which are functions which assume the boolF : ' = | | 20200104 | rplcd use of ' aux words w ' lpstk freeing use of ' aux >lpstk 1p R@ i# 0 ?do R@ i i@ lpstk@ execute if lpstkdrop 1P i _i unloop ;then loop lpstkdrop R@ rho 1P> ; | moved from \Furniture.f 20230512 to be defined earlier , before , eg: ' v@ : VM --aba Type@ TypeC =if toksplt ;then ref0del ; | 20230604 | made to simply return non-strings , ie: already nested . | 20200826 | was bad idea deleted 20201223.0025 | added ' dae because bunch of words don't like empties . | name from APL " Vector to Matrix " | updated to call ' VM rather than ' toksplt : blVM "bl VM ; : nlVM ( str -- list_of_strings_split_on_crlf ) "nl VM ; | Vector to Matrix on "newlines" . : lfVM ( str -- list_of_strings_split_on_cr ) "lf VM ; : htVM ( str -- list_of_strings_split_on_tab ) "ht VM ; ) ( ./CoSy/util.f | making ` ' state smart so ` ['] not needed . Should have done early on | 20200214 | macro : ' compiling? if p: ['] ;then prior ' ; forth | kills fns in ` gui . : stkprmpt $.s cr " ok> " type ; | use : ' stkprmpt >defer prompt | set default prompt to show stack in hex . use undo to reset to original ) ( ./src/reva.f | redefine ' and ['] to throw as per Bob Armstrong's suggestion: : '' dict? ; | : ' xt? ; macro : ['] ' p: literal ; forth : 2constant create swap , , does> 2@ ; : value ['] 'value setclass ((const)) ; ~priv : (value) [''] 'value isa then,> ; exit~ macro : to (value) then,> ! ; : +to (value) then,> +! ; forth | implementation of 'dump' : ~priv 0 value dump$ : dumpasc dump$ count dup 0if 2drop else 16 over - 3 * spaces type then cr dump$ off ; : ?nl dup 0; 16 mod not 0; drop over dumpasc .x ; : >printable dup 32 127 between not 0; 2drop '. ; exit~ ~util : dump 0; dump$ off over .x 0do | iterate for each line: i ?nl drop dup c@ dup >printable dump$ c+place .2x space 1+ loop drop dumpasc ; exit~ 0 value scratch 0 value pad ) ( ./lib/ui/gui 0 [IF] macro : action: ' literal, p: action ; : action-cb: ' literal, p: action-cb ; : resize-cb: ' literal, p: resize-cb ; : key-any-cb: ' literal, p: key-any-cb ; forth [THEN] ) ) ) ( |-- | $ | ( ./CoSy/util.f alias: $ swap | 20210727 | http://cosy.com/y21/Blog.html#20210727 | ) ) ( |-- | |>| | ( ./CoSy/util.f alias: xeq execute alias: |\/| | alias: |/\| | alias: |>| | ) ) )