| CoSy.f
| Main CoSy APL objects .
| Author: Bob Armstrong / www.CoSy.com
| Reva's license terms also apply to this file.

cr cr cr  ." Version 7 Stk bug : "  .s  ."   reset " reset cr  
cr ." Ron Aaron's " .ver ."  | http://ronware.org/reva/" cr cr
 ." staring here : "  here . cr

with~ ~sys

needs debugger

needs os/shell needs os/dir needs os/fs

: osfix ( a n -- a n ) os if unixslash then ; 

needs util/locals
needs util/misc
needs choices

| needs util/case

needs math/floats 

with~ ~doubles with~ ~floats

needs math/mod	needs asm 

| ." big "
| needs math/big
| ." big " cr

context: ~CoSy  ~CoSy 	." | started | "  .s cr

 cr  help help cr 	| shouldn't need this but interaction w ' (' causes bomb 
					| without . 20180704

: instdir appdir rem-separator split-path 2drop ; 
| From Danny (?) to make loading directory independant 
| " REVAUSERLIB" instdir add-separator setenv

| " REVAUSERLIB" " CoSy\\" osfix setenv 

needs AltStackOps.f

needs util.f

needs CSauxstack.f

 ' stkprmpt >defer prompt
 | set default prompt to show stack in hex . use " undo prompt " to reset to normal

cr ."  | basic needs satisfied | " 

| \/ FOR DEBUGGING \/  ==================================== \/
 
defer AT+> 	make AT+> ; 		
defer FT+> 	make FT+> ; 

alias: nakedallocate allocate 	alias: nakedfree free

: allocate prior allocate AT+> ;  ( bytes -- a )
: free FT+> prior free ; 
 
| /\ FOR DEBUGGING /\  ==================================== /\

| DYNAMIC  \/ ================================================== \/
cr ." \\/ DYNAMIC \\/  "  $.s cr 

| The fundamental objects in CoSy are vectors ( lists ) and functions .
| /// All lists have a 4 cell header :
| /// ( type  count ( bits refs ) meta	)  <---   body of object   --->  |  
| 20250526.1419 | > /\ is stale . Bits per item will be discontinued , and ` meta has never been used and also will go .
| effectively the header is `( Type Count refCount )`

| See also | http://cosy.com/CoSy/Structure.htm
| http://cosy.com/CoSy/4th.CoSy.html#CoSyHeader

4 constant Head#

: (valloc) aligned dup allocate	dup rot 0 fill ; 
: valloc ( n -- a ) Head# cells + (valloc) ;  ( bytes -- addr )
       | allocate n bytes  + Head# cells
       | ( type ; i# ( rho ) ; ( refs ; bits % cell ) ; meta )
       | 0 fills the allocated memory . This could be reduced to just the
       | head cells for speed .

: i# ( adr -- number_of_items ) cell+ @ ; 	| "count" ; K # , like APL ` rho

: i#i# ( la ra -- la ra i# i# ) | leaves obs on stack since not ref chkt 
  over i# over i# ; 

: `BnR 2cell+ ;       | top half of 3rd cell is item size in bits
                      | bottom word of 3rd cell is reference count .
: bits! `BnR hw! ; 
: bits@ `BnR hw@ ; 

: Ibytes bits@ byte / ; 	| bytes per item 

: vbody ( vadr - vBodyAdr ) Head# cells +  ; 	| beginning of data 

: vbytes ( v -- n )		| total data bytes
   dup i# swap Ibytes * ; 

: vsize ( addr -- n )	| # bytes in whole object , aligned
   vbytes aligned Head# cells + ; 

: van ( v -- a n )		| start-of-data , # bytes
   dup vbody swap vbytes ; 

: Vresize  ( Ob i -- Ob )	| resizes , trucates only , vector to n items .
  | used mainly for freeing waste space on large initialized buffer vecs .
  2dup swap cell + ! over Ibytes * Head# cells + resize
  ?dup 0if z" Vresize failed " throw then ;  

: ix    ( adr n -- adr of nth item in list ) | modulo indexing
  over i# ?dup 0if z" can't ix empty " throw ;then  | 20210122 | tested if can just return empties . Nope 
   _mod over Ibytes * vbody + ; 
 
| Modulo indexing is a very fundamental feature of CoSy . 
| It means an index can never go out of range because it simply wraps . 
| It means the shorter of 2 lists is cyclically repeated to match the longer . 
| A list can be addressed from the end with negative indices . eg 
| See Furniture.f  2scomp |

| Objects are initialized with a reference count of 0 .
| In general functions decriment the reference count on exit , freeing
| the object if the reference count is 0 or less .
| If a fn calls other fns which check refs , or are operators which may
| be called with unknow fns , generally  refs+  must be called on entry
| to protect the objs for the duration of the fn , then refs- before exit .
| If the fn does not call any other ref smart fns , it can just use 
| ref0del before exit .
| See the decrementing fns right after the definitions of enclose .

: refs! `BnR w! ; 
: refs@ `BnR w@ ; 

: refs0 0 swap refs! ; 	: refs1 1 swap refs! ; 	: refs-1 -1 swap refs! ; 

( DEBUGGING @ ) 0 [IF]
: refs+ ( obadr -- )  dup ."  r+ " $. 
  `BnR 1 swap w+! ; 
[ELSE]
: refs+ ( obadr -- ) dup refs@ dup 0 <if 2drop ;then 1+ swap refs! ; 
	| was | `BnR 1 swap w+! ; 
[THEN] 

: refs+> dup refs+ ;      ( obadr -- obadr )
: 2refs+  refs+ refs+ ; 		| useful for LA RA 
: 2refs+> 2dup 2refs+ ; 

: .. : .+ : dup+ dup refs+> ;  | dup incrementing ref count   | 20230302 | added  ` .+  alias 

 macro 
: ]+ p: refs+> p: ] p: literal ; 	| for compiling CoSy dynamic obs in defs . eg ...  [ `( sys CoSySource )` ]+ Dv@ ... | 20250213
 forth 

| \/ \/ \/ LIST TYPES \/ \/ \/
| Mon.Feb,20080225 | I changed my original early APL like type labeling scheme
| for a cul-de-sac notion of direct addresses for type function . 
| Silly . Not stable from one compile to another .
|  Am thinking about going to simple index list in order of creation so can
| index to handler fns simply . But problems w that , too . 

| \/ nil \/ | 	This needs work .
| see  util  0I +1 constant _n		| _n is its own type 
 
_n constant TypeN
| create nil  TypeN , 1 , $00000001 , _n ,	| nil vector . |X only needs head X|  
|  nil nil meta!
 
create nil  TypeN , 1 , $00000001 , nil , _n ,	
 | nil vector . |
| alias: _n nil | tried to do something profound . doesn't work | 20200211 |
 
: _n; ( n -- n | _n &exit ) dup _n =if rdrop then ; 
 
| /\ nil /\ | 	This needs work .

| \/ The most general type : CELL \/

0 constant Type0 

: cellVecInit ( n - objAdr )    | make header and allocate space for n cells
   dup cells valloc           ( n objAdr )
   dup Type0 swap !					| type 0
   dup cell+ rot swap !         | # of items
   dup cell byte * over bits!   | item size in bits 
   refs0 ; 

: ic@ ( v i -- o ) ix @ ; 	
: ic! ( o v i -- ) ix ! ; 	| index fetch and store , cell 
 
 alias: ii@ ic@		alias: ii! ic!	| index fetch and store , integer

0 cellVecInit refs+> constant ev        | : ev  | empty vector

: vdup ( adr -- newadr ) | returns copy of object  
  dup vsize dup allocate >r> swap move r@ refs0 r> ; 

| \/ \/ \/ TYPES \/ \/ \/ |

alias: Type@ @		alias: Type! !  

: Type@@ : @@ ( la ra -- la ra la@ ra@ ) over @ over @ ; 
  | fetches top 2 items , leaves items on stack

: typechk ( LA RA type -- flag ) 	| check both arg types match desired
	>r Type@ swap Type@ over = swap r> = = ; 

: simple? ( ra -- f ) Type@ M->I ; 


 ."  \/ INTEGER \/ "  .s cr 
   
4 constant TypeI		| single cell INTEGER 

| { ." integer " } value TypeI

: int> dup : int TypeI swap ! ; 	| convert type to int | int> returning

: intVecInit ( n - objAdr )		| make header and allocate space for int vec of length n
   cellVecInit int> ; 			| integer vector type -1

 0 intVecInit refs+> value ei 	| : ei  | empty integer vec | renamed from evI 20190121.	 

: _i ( cell -- 1_item_intvec ) 
   1 intVecInit >r> 0 ii! r> ; 
 
: 2_i ( i i -- iv iv )  _i swap _i swap ; 

 0 _i refs+> constant i0 
 1 _i refs+> constant i1
-1 _i refs+> constant i-1 

| Basic header info . Does not effect object .
: Type @ _i ; 	| Return Type , content of first cell , as a list | 20200510 | !
 
: Count i# _i ; | Return Count , content of 2nd cell , as a list | 20200603 | ! | fixed comment typo . See SV-FIG presentation 20240224
 
: Ref# refs@ _i ; | Return Reference Count 3rd item ; currently half cell | 20200603

: longer_ ( LA RA -- lengthOfLonger )	| Generally fns index shorter til longer  
   i# swap i# max ; 
: longer longer_ _i ; 

: shorter_ ( LA RA -- lengthOfShorter )	| Generally fns index shorter til longer  
   i# swap i# min ; 
: shorter shorter_ _i ; 


| \/ Enclosing - making general list from an atom \/   

: ?enc ( lst -- Iflag )         | return 1 if enclosed else 0
  @ 0=I ; 

: 0encabort ( CSob -- CSob )    | Abort if not enclosed
  dup @ sn z" not enclosed " throw ; 

: 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 ; 

| \/ REF decrementing \/
| when the ref count of a general or enclosed list is decrimented ,
| each item must recursively be decrimented also .

( DEBUGGING @ ) 0 [IF]
: refs- ( obadr -- )	| decrements reference count , frees if 0 .
 dup ."  r- " $. 
  dup refs@ 1 -   
  dup 0 >if swap refs!
  else over ?enc
   if over i# 0 ?do over i ic@ refs- loop then
    drop free then ;      | decrement refs & free if 0
[ELSE]
: refs- ( obadr -- )	| decrements reference count , frees if 0 .
  dup refs@ dup 0 <if 2drop ;then 1 -   
  dup 0 >if swap refs! ;then
   over ?enc
   if over i# 0 ?do over i ic@ refs- loop then
    drop free ;      | decrement refs & free if 0
[THEN] 

: 2refs-  refs- refs- ; 

: refs-ok> dup : refs-ok ( DEBUGGING @ ) 0 if dup ."  r- " $. then  
  `BnR -1 swap w+! ; 	| sometimes need to decrement but not free .

: ref0del dup refs@ 0if refs- else drop then ; 	| free if refs = 0 .
 | Thursday, June 02 2005 - 11:49 | I am concluding it is vital
 | for functions to free .. locally created obs w ref0del if
 | not returned as result , but leave input parameters alone .
 | input parameters consumed should be freed if 0 refs .
 
: 2ref0del ref0del ref0del ; 

: # : rho ( list -- #L ) dup i# _i swap ref0del  ; 	
 | Same as i# but CoSy list result

: onvbody ( LA~? RA fn -- res ) | executes fn on body of RA , 
   >r vbody r> execute swap ref0del ; 

: onvan ( RA fn -- res ) | executes fn on van of RA , generally string 
  >r dup van r> execute swap ref0del ; 

: Eval ( .. str -- ? ) >r> van eval r> ref0del ;  | depricating ` ^eval | 20200228 | deleted ^eval 20240107 |
| evaluates a CoSy string which can , of course , take & put args on the stk .


| : sink refs- nil ; 	| discard result , return nil | not happy w def . never used | commented out 20241113

| : ref0free refs@ 0if free then ; 	| sometimes need to free w/o releasing
| 	| contents , eg , ' reverse . 

| \/ \/ | PARAMETER PUSHING | \/ \/ | | See p stack fns in CSauxstack.f 
 
 needs ParameterPushing.f

| /\ /\ | PARAMETER PUSHING | /\ /\ |  
 cr .s cr 

: >value refs+> value ; 

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 ; 

ev >value t4
: >t4> dup : >t4 ( ob -- ob )      | Another Temp handle holder | 20210727 |
   t4 refs-  refs+> to t4 ; 

."  \/ OPERATORS ON GENERAL VECS \/  "

| simple looping of expression xt n times . Must be " self contained " leaving nothing on stack . 20190101
: nxtimes ( n xt --  ) swap 0 ?do dup xeq  loop drop ; 	| saved to CoSy.f

: eachMcr ( CSob fn -- CSadr )	| `each Monadic cell resulting
   over refs+> vdup >aux		| fn must not change type .
   over i# 0 ?do over i ic@ over execute aux@ i ic! loop
   drop refs- aux> ; 

: eachDcr ( LA RA fn -- R )		| each Dyadic on cells , resulting   
  -rot 2dup 2refs+> longer_ dup cellVecInit	| fn LA RA n r 
  swap 0 ?do 2 pick i ic@ 2 pick i ic@ 5 pick	| fn LA RA r LAi RAi
   execute over i ic! loop		| fn LA RA r 
  -rot 2refs- nip ; 
    
: eachMir eachMcr int> ; 
: eachDir eachDcr int> ; 

defer aaply defer aaplym

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> -- int ) parsews >single if _i ;then	| changed name from ` i^ | 20220615
   2drop z"  not integer" throw ;  
forth

: str>i >a> van eval _i a- ; 	| CoSy string > integer | 20200912 


| \/ | Integer functions | \/ |  	| pre ' aaply defs deleted 20221011
 
| Dyadic 
: +i { ['] + eachDir } aaply ; 	| add 2 integer vecs 
: -i { ['] - eachDir } aaply ; 	| subtract 2 integer vecs 
: *i { ['] * eachDir } aaply ; 	| * 2 integer vecs 
: %i { ['] / eachDir } aaply ; 	| div 2 integer vecs 
: modi { ['] _mod eachDir } aaply ; 	| _mod 2 integer vecs 
: /\ : mini { ['] min eachDir } aaply ; 	| min 2 integer vecs . "and" on booleans | Had \/ backwards til 20240719
: \/ : maxi { ['] max eachDir } aaply ; 	| max 2 integer vecs . "or" on booleans  | Had /\ backwards til 20240719
: ori { ' or eachDir } aaply ; 	| bitwise ' or | finally added 20201228 |
: xori { ' xor eachDir } aaply ; 	| bitwise ' xor | finally added 20240826
: andi { ' and eachDir } aaply ; 	| bitwise ' and | finally added 20201228 |
 
: =i { ['] =I eachDir } aaply ; 	| = ( Iverson logic ) 2 integer vecs 
: 0<>i i0 : <>i { ['] <>I eachDir } aaply ; 	| not equal ( Iverson logic ) 2 integer vecs 
: 0<i i0 : <i { ['] <I eachDir } aaply ; 	| < ( Iverson logic ) 2 integer vecs 
: 0>i i0 : >i { ['] >I eachDir } aaply ; 	| > 2 integer vecs | 20201006

| see also ` /modi  in  C:/4thCoSy/CoSy/math.f 	| 20221011
 
| Monadic
: I>M { ['] I->M eachMir } aaplym ; 	| Iverson to Moore logic  1 > -1 on list | 20200202
: M>I { ['] M->I eachMir } aaplym ; 	| Moore to Iverson logic <>0 > 1 on list | 20200202
 
: absi { ['] abs eachMir } aaplym ; 	| abs
: -0+i { ['] sn eachMir } aaplym ; 		| sign 
: 0=i ( int -- bool )  i0 =i ; | essentially "not" 
: -1*i ( int -- negate ) i-1 *i ; 
: 1+i i1 +i ; 	| 20211210 |		
 
| /\ | Integer functions | /\ | 

: I. ( iv -- )	| output integer list .
 dup i# 0 ?do dup i ii@ . loop ref0del ; 

: $I. hex I. decimal ; 

: ,I ( I0 I1 -- I0,I1 ) | catinates integer vecs .
  2dup i# swap i# + intVecInit >aux
  over dup i# 0 ?do dup i ii@ aux@ i ii! loop 
  i# over dup i# 0 ?do dup i ii@ aux@ 3 pick | I0 I1 I0# I1 I1@ aux 
    i + ii! loop 2drop 2ref0del aux> ; 
  | It is so uncommon that I write something right the very first time that
  | I here make a note that I did just now  20060516.0105


: intVec ( n-items n -- oAdr )	| make int vec from n items on stack .
  dup intVecInit >r> vbody s>m r@ i# ndrop r> ; 

| \/ BYTE ( CHARACTER ) \/	  

1 value TypeC
| { ." character " } value TypeC 

: byteVecInit ( bytes - OA )    | make header and allocate space for n bytes
   dup 1+ valloc dup TypeC  swap !   ( n objAdr )  | type vec of 8 bit items
   dup cell+ rot swap !         | # of items | Plus one char for use with zt .
   dup byte over bits!          | item size in bits
   refs0 ; 

: ib@ ix c@ ; 		: ib! ix c! ; 	| index fetch & store , byte

: _b 1 byteVecInit >r> 0 ib! r> ; 

| \/ | STRINGS | \/ |
: _str ( a better name ) : str ( c-addr n -- OBadr )     | store a string
  dup byteVecInit dup >r        | c-ad n Oadr
  vbody swap move r> ; 

: str< ( c-addr n -- str )     | store a string and free 
  --aab _str swap free ; 

: spool ( ... fn -- str ) (spool) _str ; 
| moved from Furniture.f to as soon as definable . | 20180602 

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

s" " refs+> constant ec 	| : ec 	| empty char string  

s"  " refs+> constant "bl 
s" ;" refs+> constant "; 
s"  " refs+> dup vbody CR swap c! constant "cr 
s"  " refs+> dup vbody LF swap c! constant "lf 
s"   " refs+> dup vbody dup CR swap c! LF swap 1+ c! constant "nl 
s"  " refs+> dup vbody HT swap c! constant "ht 

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 ; 
forth 

macro
: `( 		| input non-blank strings up til " )`" . return as list of words
  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

: ,s ( s0 s1 -- s0,s1 ) | catinates strings .
  2dup i# swap i# + byteVecInit >aux
  over dup i# 0 ?do dup i ib@ aux@ i ib! loop 
  i# over dup i# 0 ?do dup i ib@ aux@ 3 pick | see `,I 
    i + ib! loop 2drop 2ref0del aux> ; 

: takeb ( iv n -- iv )             | APL take / reshape on bytes
  dup abs byteVecInit >aux
  dup 0 <if 0 swap else 0 then		| if n neg , 0 n  do 
  ?do dup i ib@ aux@ i ib! loop ref0del aux> ; 


: stype ( str -- )	| string output  	| 20220509
   dup van type ref0del ; 

: strout ( StrAdr chr -- )      | output various labeled string types 
   emit ." \" " stype ." \" " ; 
 
: C. ( StrAdr -- ) ( 's strout ) stype ;   | output string

: C.cr C. cr ; 


| \/ FLOAT \/ | ===================== | 

| round.up		| Set FPU rounding mode 

10 constant TypeFl 
| { ." float " } value TypeFl

: floatVecInit	( n - objAdr )	| make header and allocate space for float vec of length n
   dup floats valloc 	( n objAdr )
   dup TypeFl swap !				| type 0
   dup cell+ rot swap !			| # of items
   dup b/float byte * over bits!   | item size in bits 
   refs0 ; 

: 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 ; 

: f_ ( f -- fstk: f ) dup 0 if@ ref0del ; 
| Put single CoSy float in fstk . frees if 0 refs | 20190912  

 0 floatVecInit refs+> constant ef 	| : ef 	| empty float vec

 0. _f refs+> constant f0.  1. _f refs+> constant f1. 	-1. _f refs+> constant f-1.

| like  >float  but converts integer strings too | WARNING ! Fails on ints > 2^30 without trailing decimal point | 20241011  
: >>fl ( a n - see >float )  >float if true 
	else >single if s>f true else false then then ;  

macro
: f( 	| input floats up til " )f" . return FV .
  100 K* dup floatVecInit	| I'm trusting that resize really frees unused mem
   swap 0do parsews >>fl  
     if dup i if!  
     else 
      " )f" cmp if free z" not number " throw then 	| i/o error 
      i Vresize leave
	 then loop ; 

: `f parsews >>fl drop _f ; 	| ` prefix version of ' _f 
forth

| /\ FLOAT /\ | ===================== | 

: v#@ ( v -- count&type )  dup i# swap @ ;  

: VecInit  ( n type -- vec )
  case
   Type0  of cellVecInit	endof
   TypeI  of intVecInit		endof
   TypeC  of byteVecInit	endof
   TypeFl of floatVecInit	endof
   drop cellVecInit 
  endcase ; 

cr ."  \\/ each \\/ " $.s cr
| ======================================== |

: eachMfr ( RA fn --  r ) 	| each Monadic on floats , resulting 
  over refs+> i# dup floatVecInit >aux
  0 ?do over i if@ dup execute aux@ i if! loop
  drop refs- aux> ; 
 
: eachMfir ( RA fn --  r ) 	| each Monadic on floats , cell resulting   | 20240725
  over refs+> i# dup intVecInit >aux
  0 ?do over i if@ dup execute aux@ i ii! loop
  drop refs- aux> ;   

: eachMifr ( intVec fn -- floatVec ) 	| each Monadic on integers , float resulting
   >lpstk dup i# dup floatVecInit >aux 
   0 ?do dup i ic@ aux@ i ix swap lpstk@ execute f! loop 
  ref0del lpstk> drop aux> ; 
 
: eachDfr ( LA RA fn -- r ) 	| each Dyadic on floats , resulting 
  -rot 2dup 2refs+> longer_ dup floatVecInit >aux
   0 ?do over i if@ dup i if@ 2 pick execute aux@ i if! loop
   2refs- drop aux> ; 
 
: eachDfir ( LA RA fn -- r ) 	| each Dyadic on floats , cell resulting 
  -rot 2dup longer_ dup intVecInit >aux
   0 ?do over i if@ dup i if@ 2 pick execute aux@ i ii! loop
   2ref0del drop aux> ; 

: takef ( fv n -- fv )             | APL take / reshape , float
  dup abs intVecInit >aux
  dup 0 <if 0 swap else 0 then		| if n neg , 0 n  do 
  ?do dup i ii@ aux@ i ii! loop ref0del aux> ; 

| \/ | Float fns | \/ |  pre ' aaply defs deleted 20221011
 
: +f { '  f+ eachDfr } aaply  ; 	| add 2 float vecs 
: -f { '  f- eachDfr } aaply  ; 	| subtract 2 float vecs 
: *f { '  f* eachDfr } aaply  ; 	| * 2 float vecs 
: %f { '  f/ eachDfr } aaply  ; 	| div 2 float vecs 
: ^f swap { '  f^ eachDfr } aaply  ; 	| LA ^ RA . Note arguments swapped from Intel order to standard 

| \/ | cann't figure out how to embed these under ' aaply . 20221105
: =f { f= M->I } eachDfir ; 	| = ( Iverson logic ) 2 float vecs 
: <f { f< M->I } eachDfir ; 	| < ( Iverson logic ) 2 float vecs 
: >f { f> M->I } eachDfir ; 	| > ( Iverson logic ) 2 float vecs 
| /\ | 

: fmin fover fover f< if fswap then ; 	| not defined in lib/math/floats 
: fmax fover fover f> if fswap then ; 	| not defined in lib/math/floats 

: minf { '  fmin eachDfr } aaply  ; 	| 
: maxf { '  fmax eachDfr } aaply  ; 

: 1%f { '  1/f eachMfr } aaplym  ; 
: negatef { '  fnegate eachMfr } aaplym  ; 	| 20211114 |
: floorf { '  ffloor eachMfr } aaplym  ; 	| f( 3.14 -3.14 )f floorf 	|>| 3.0000 -4.0000 
: intf { '  fint eachMfr } aaplym  ; 		|  f( 3.14 -3.14 )f intf 	|>| 3.0000 -3.0000  	
: absf { '  fabs eachMfr } aaplym  ; 		| -n.m -> n.m 
: sqrtf { '  fsqrt eachMfr } aaplym  ; 
: fracf { '  ffrac eachMfr } aaplym  ; 
: lnf { '  fln eachMfr } aaplym  ; 	10. fln _f >value ln10 	: l10f lnf ln10 %f ; 	| factored ln10  | 20240923
: expf { '  fexp eachMfr } aaplym  ;  | 20250609.0741 | Never previously defined !
: sinf { '  fsin eachMfr } aaplym  ; 
: cosf { '  fcos eachMfr } aaplym  ; 
| : tanf { '  ftan eachMfr } aaplym  ; 	| ' ftan WRONG in floats.f 
: tanf { .+ sinf $ cosf %f } aaplym ; 	| 20230908.2111
: deg>radf { '  deg>rad eachMfr } aaplym  ; 	| 20210711
: rad>degf { '  rad>deg eachMfr } aaplym  ; 	| 20210711

: f^2 fdup f* ; 	| not defined in lib/math/floats .
 | Much more efficient than { rep *f }  . Just 2 x87 instructions .
: ^2f { '  f^2 eachMfr } aaplym  ; 
 
| /\ | Float fns | /\ | 

: F. ( fv -- ) dup i# 0 ?do dup i if@ f. loop ref0del ;  | output float 

: i>f ( ints -- float ) { ' s>f eachMifr } aaplym ;  | factored & made atomic . 20240725
: f>i ( floatVec -- intVec ) { ' f>s eachMfir } aaplym ; | made atomic . 20240725

| ( x y -- round x to y places ) | 20200221 
: rnd  10. _f swap ^f >a> *f .5 _f +f floorf a> %f ; 


| \/ OTHER \/	 
0 [IF]
$4d7e6d value TypeInterval		| " m~M" ( min to Max )
: interval ( LA RA -- interval )  | really just a pair of endpoints
  | w b useful to optimse indexing . 
  2 intVec dup TypeInterval swap ! ; 

cr ."  \\/ raw fn types \\/ " $.s cr
| \/ RAW FN TYPES  \/ \/ \/
| still need to clean up or out | \/ | 20200221 
$10000 constant TypeV 		| verb
$20000 constant TypeA 		| Adverb
$40000 constant TypeFv 		| FORTH verb
[THEN]  

| \/ |  a wrong approach to ` genericity . May be fully vestigial | 20190906 
a[ intFns ' + , ' - , ' * , ' / , ' _mod , ' = , ' =I , ' and , ' or , ' <>I , ' >I , ' <I , ' 0=I , ' negate , ' @ , ' i# , ' i@ , ' i! , ' refs@ , ' bits@ , ]a

a[ floatFns ' f+ , ' f- , ' f* , ' f/ , ' f= , ' fsin , ' fcos ,
   ' ftan , ' fatan , ' fnegate , ' f0 , ' f1 , ' fpi , ' fabs , ' fsqrt ,  ]a

: verb? dup _n =if false ;then ( Type TypeV TypeA TypeFv or or ) $70000 and ;  
: noun? verb? not ; 

: fntype ( fn -- type )		| result type
   dup intFns swap a? if drop TypeI ;then  
   dup floatFns swap a? if drop TypeFl ;then
   drop Type0 ; 		| if none of the above assume cell   
| /\ | 

| ======================================== |

choices: ifetch ( vec idx type -- val )
 ' ic@ Type0 choice		' ii@ TypeI choice
 ' ib@ TypeC choice		' if@ TypeFl choice
 ' ic@ default 

: i@ ( a i -- item ) 
  over @ ifetch ; 

: i@i@ ( l r i -- lr rr ) >r swap r@ i@ swap r> i@ ;    

: >_ ( disclose  non-nested  and free if 0 refs ) dup 0 i@ swap ref0del ; 

: rplc ( new p0 -- )   | ref- and replace pointer at ' p0
  dup @ refs- swap refs+> swap ! ; 
 | swapped order : over @ refs- refs+ swap ! 

macro  : => ( noun <obj> -- ) p: addr rplc ;   forth 

: i0! over refs+ ic! ;  

choices: istore
 ' ic! Type0 choice		' ii! TypeI choice 	| c for "cell"
 ' ib! TypeC choice		' if! TypeFl choice
 ' ic! default 

: i! ( item a i -- ) 
  over @ istore ; 


| 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 ; 
  
| APL's ` iota on a CoSy integer singleton . And version returning float .
: iota  >_ _iota ;  : _iotaf _iota i>f ;  : iotaf iota i>f ; 
 
: _iota1 _i : iota1 iota 1+i ; 	| 1 origin version |  20250107

| appear to appear nowhere else  | 20180908.2146
| : t@ ( lst idx -- val type ) over @ >r> ifetch r> ; 
| : >^ ( val type -- 1#List ) 1 swap VecInit >r> 0 i! r> ;   
| : ^@ ( lst idx -- ^itm ) t@ >^ ; 
| delete if no problem .

: s>iv ( . . . n -- iv ) | makes int vec of top n items on stack | 20190817
  intVecInit >aux>  i# 0 ?do aux@ remains ii! loop aux> ; 
 
: s_n? ( . . _n . . . -- . . _n . . . n )	| Returns depth to first
| occurance of nil ( _n ) . Returns  depth  if no _n . 
   depth 0 ?do i pick _n =if i unloop ;then loop depth ; 
 
: s_n>iv ( . . _n . . . -- iv )  s_n? s>iv nip ; 
| makes int vec of stack down to occurance of _n

: v?refs+ ( v -- ) | increment ref count of each item of enc list .
   dup @ 0if dup i# 0 ?do dup i i@ refs+ loop then drop ; 

: s_n>ev ( . . _n . . . -- iv )  s_n>iv dup Type0 swap ! dup v?refs+ ; 
| makes enclosed vec of stack down to occurance of _n


choices: out
 ' I. TypeI choice		' F. TypeFl choice
 ' C. TypeC choice
 :: ref0del z" nonce " throw ; default 

cr ."  \\/ ops \\/ " $.s cr
| \/ OPERATORS \/ ========================================== \/

| cr cr  ." 0000 " ." Stk : "  $.s  cr cr 

: 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
| APL standard . but hasn't been used . ` g needs to be self-inverse | 20250401

: Times ( xt n -- r ) $ >lpstk >_ 0do lpstk@ xeq loop lpstkdrop ;   | 20250401
| Like Dyalog ` power or ` repeat with integer arg . Repeats xt n times 


: eachM ( v fn -- ) over refs+> i# 0 ?do over i i@     | CSob fn item
   over execute loop drop refs- ; 
| primative `each Monadic , no result , eg , printing | 

." ---- " cr

: 0th : dsc ( obj -- first_item ) | ` disclose . returns 0th item , | 20130923.230527 | adding ` 0th alias to match 1th | 20240201
  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 

: _at\ ( Lst idx -- items )  _i   : at\ ( v i -- v )  
| fundamental indexing fn . Always returns enclosed list of enclosed item
   dup i# --abca Type@ VecInit >aux>  i#		| v r #
   0 ?do 2dup i i@ i@ aux@ i i! loop
   aux@ v?refs+ 2ref0del aux> ; 

: 1th 1 : _at@ : _at _i : at@ : at ( v i -- v ) | discloses if singlton index .  | aliased at@ for symmetry w ` at!  | 20240227
| 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! _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 ; 

: '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>  ; 

| ( v -- ( v i# items on stack ) ) splits v into separate items on stack . 
| Corrected refcounting error . had to get down & dirty | 20200902.1633 | 
: lst>stk >aux> i# 0 ?do aux@ i i@ refs-ok> loop aux> dup refs@ 0if free then ; 

: lst>stk_ >a> i# 0 ?do a@ i i@ loop a- ; 	| raw version for chars & ints


: each ( LA RA fn -- R )
   over Type@ TypeFl =if eachDfr ;then 	| Floats are sui generis
   --abcab 2refs+> longer_ over fntype VecInit >lpstk>
   i# 0 ?do 2 pick i i@ 2 pick i i@ 2 pick execute lpstk@ i i! loop
   lpstk@ v?refs+  drop 2refs- lpstk> ; 

: 'L : eachleft ( LA RA fn -- R )	| execute fn using RA over each item of LA
   dup fntype TypeFl =if z" nonce " throw ;then 	| Floats are sui generis
   --abcab 2refs+ 2 pick i#  over fntype VecInit >lpstk>
    i# 0 ?do 2 pick i _at --abcab execute refs+> lpstk@ i i! loop
	drop 2refs- lpstk> ; 

: 'R : eachright ( LA RA fn -- R )
  | iterates over raw items of RA . result of fn must be a CoSy object 
  >r 2p r> | fntype TypeFl =if z" nonce " throw ;then 	| Floats are sui generis
    R@ i# l0@ fntype VecInit 
    dup i# 0 ?do L@ R@ i _at l0@ execute refs+> l1@ i i! loop 
   l1@ 2P> ; 

| \/ |  Atomic Apply operators . Apply verb to simple leafs of noun  | \/ | 
| see | 20180226 | 
 
:: ( n v -- r ) 		| : aaplym 
   swap 1p 
   R@ Type@ 0if  | ." ( BRANCH ) " 
      R@ i# cellVecInit >lpstk>		| Res 
    	i# 0 ?do R@ i i@ L@ ( $.s cr ) aaplym refs+> lpstk@ i i! loop
    	1P drop lpstk>		| 
	else | ." ( LEAF ) " | 
	 R@ L@ ( $.s cr ) execute 1P> nip 
    then ; 
 is aaplym
 
 :: ( LA RA fn -- r ) 	| : aaply 
   --cab 2p 
   R@ Type@ 0if
     L@ Type@ 0if | ." ( BRANCH ) both nested "  
       LR@ longer_ cellVecInit >lpstk>
        i# 0 ?do LR@ i i@i@ 3 SF@ aaply refs+> lpstk@ i i! loop lpstk> 
   	  else | ." ( L LEAF  R NEST ) " 
   	  R@ i# cellVecInit >lpstk> 
   	   i# 0 ?do L@ R@ i i@ 3 SF@ aaply refs+> lpstk@ i i! loop lpstk> 
   	  then
    else ( R LEAF )
   	 L@ Type@ 0if | ." ( R LEAF L NEST ) " 
   	  L@ i# cellVecInit >lpstk> 
   	   i# 0 ?do L@ i i@ R@ 3 SF@ aaply refs+> lpstk@ i i! loop lpstk> 
   	  else | ." ( both LEAF ) "  
   	   LR@ 3 SF@ execute 
	  then
	then 
	2P> nip 
	; 
 is aaply

|  Best to handle typing outside of loops .

| \/ | ` across words  | see also  https://www.cosy.com/K/html/kref.pdf  ` OVER

: acrossY  local[ proto obadr fn | n r -- res ]    | dYadic result returning "/"
   obadr i# to n  obadr vbody to obadr  proto to r
   n 0 ?do r obadr i c+ @ fn execute to r  loop
   r ; 

: acrossI  ( RA fn -- r )		| result returning "/" on integer lists 
   over 0 i@ -rot		| r RA fn   
   over i# 
     1 ?do 2 pick 2 pick i i@ 2 pick execute 2 put  loop
   drop ref0del _i ;   

: acrossYf  ( f:r0 RA fn -- r )	| result returning "/" on float lists 
	 over refs+> 	| LA is initial result ( identity element ) on f stack  	  
    i# 0 ?do over i if@ dup execute loop
   drop refs- 1 floatVecInit dup 0 if! ; 

: acrossf  ( RA fn -- r )	| result returning "/" on float lists 
	over i# 0=I z" nonce : empty , needs prototype " * throw 	
    over refs+> dup 0 if@
    i# 1 ?do over i if@ dup execute loop
   drop refs- 1 floatVecInit dup 0 if! ; 

: acrossC  ( RA fn -- r )	 | result returning "/" on cell lists 
   over 0 i@		| RA fn r	| bombs on empty arg . use acrossYc		 	  
   2 pick i# 
     1 ?do 2 pick i i@ 2 pick execute loop
   >r drop ref0del r> ; 

: Y./ : acrossYc  ( LA RA fn -- r )	| result returning "/" on cell lists 
	rot		| RA fn r	| LA is initial result 	  
   2 pick i# 
     0 ?do 2 pick i i@ 2 pick execute loop
   >r drop ref0del r> ; 

: across  ( RA fn -- r ) | result returning "/" |
   over i# 0if drop ;then       |  empty simply returns itself 
   over i# 1 =if drop dsc ;then | 1 item discloses ( ala K )
   dup fntype TypeFl =if acrossf ;then
   dup fntype TypeI =if acrossI ;then 	| 20200802
   over refs+> 0 i@ >lpstk
   over i# 1 ?do lpstk> 2 pick i i@ 2 pick execute >lpstk loop
   drop refs- lpstk> ; 

: acrossN ( RA fn -- r ) $.s  swap 1p $.s cr 
   R@ i# 0if ." empty  " $.s cr drop R@ 1P> ;then 	| if empty , just returns .
  R@ Type@ case $.s cr 
   Type0 $.s ."  | " of $.s cr R@ swap across endof  
   TypeI  of ['] + acrossI endof 
   TypeFl of ['] f+ acrossf	endof 
   drop refs- z" invalid type " throw
  endcase 
   $.s cr 1P> ;   

: _./  ( LA fn -- r ) | result returning "/" , "across" on naked fns
| If empty or singlton , simply returns arg . 
   over i# 2 <if drop ;then
   >lpstk   refs+> >lpstk> 0 _at\ lpstk@ 1 _at\ lpstkx@ execute 
   lpstk@ i# 2 ?do lpstk@ i _at\ lpstkx@ execute loop
   lpstk> refs- lpstkdrop ; 

: ./ : across^  ( RA fn -- r ) | result returning "/"  on CoSy obs
| If empty or singlton , simply returns arg . | 20201125 | updated to match _./ better rule
   over i# 2 <if drop ;then
   over refs+> >r> i0 at\ r> i1 at\ --abca execute >lpstk
| aux@ . ." here " $.s cr
   over i# 2 max 2 ?do lpstk> 2 pick i _at\ 2 pick execute >lpstk loop
   drop refs- lpstk> ; 

| ( noun verbFraez -- res ) execute across | see 20190623 . 
: ./e >lpstk >a> i# 0 ?do a@ i i@ lpstk@ execute loop lpstkdrop a- ; 

: +/ ( 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 ; 

| -------- 

: scanf  ( RA fn -- r )	| result returning "\" on float lists 
| fn must be raw floating fn . 
	over i# 0=I z" nonce : empty , needs prototype " * throw 	
    over refs+> i# floatVecInit >lpstk 
	over 0 if@ lpstk@ 0 if! 
    over i# 1 ?do lpstk@ i 1- if@  over i if@  dup  execute  lpstk@ i if! loop
    drop refs- lpstk> ; 

: _.\ : 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> ; 

: scanI  local[ RA fn | R -- R ]     | raw scan over interger vecs .
  RA i# intVecInit to R  RA 0 i@ R 0 i!
  RA i# 1 ?do R i 1- i@  RA i i@ fn execute R i i! loop
  RA ref0del  R ; 
 | done | NB : it might be possible to move this before , and use it in  refs- .

| ` scan , integral , for ` CoSy level fns . like running ` ./  | 20230414 20230416
: .\ ( RA fn -- r ) >aux 1p> dup i# $ Type@ VecInit >Lpstk
   R@ dsc lpstk@ 0 _at!  
   lpstk@ i# 1 do lpstk@ i 1- _at R@ i _at aux@ execute
     lpstk@ i _at! loop  auxdrop  Lpstk> 1P> ; 

: +\ dup Type@ TypeI =if ' + scanI ;then ' f+ scanf ;  | need | 20200228 


: _delta ( RA fn -- V )		| K ': . Applies fn between each ` raw pair of RA
	over refs+> i# 0if z" length 0 " throw then
	over i# 1- over fntype VecInit >lpstk
	lpstk@ i# 0 ?do over i 1+ i@ 2 pick i i@ 2 pick execute lpstk@ i i! loop
	drop refs- lpstk> ; 

: '.. ( RA fn -- V )		| K ': . Applies fn between each pair of RA | 20210107 | 20240101 | changed name to avoid search conflict w : defs
	over refs+> i# 0if z" length 0 " throw then
	over i# 1- over fntype VecInit >lpstk
	lpstk@ i# 0 ?do over i 1+ _at 2 pick i _at 2 pick execute lpstk@ i i! loop
	drop refs- lpstk> ; 

: convof ( LA RA fn -- res ) | Applies RA fn across LA RA rho at a time | 20190912
|  for floats . 
   >lpstk 2p R@ rho iota >a 
   L@ i# R@ i# - L@ Type@ VecInit >lpstk> i# 0 ?do
    L@ i _i a@ +i at R@ lpstkx@ execute f_ lpstk@ i if! loop
   a- lpstk> lpstkdrop 2P>  ; 
 
: convo ( LA RA fn -- res ) | Applies RA fn across LA RA rho at a time | 20200130
| must return naked value , eg: naked ints . Note that string search is a convolution .
   >lpstk 2p R@ rho iota >a 
   L@ i# R@ i# - L@ Type@ VecInit >lpstk> i# 0 ?do
    L@ i _i a@ +i at R@ lpstkx@ execute lpstk@ i i! loop
   a- lpstk> lpstkdrop 2P>  ; 

| -------- 

: _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>  ;  

| more efficient search for 1st occurance of string in string | 20180315
: ss1st ( s0 s1 -- idx ) 2refs+> 2dup >r van 
	--aab r> van search 
	if drop swap - _i --cab 2refs- ;then
	drop  --aba # --cab 2refs- ; 
| 20220419 | really fixed to return  s0 #  if not found . 


: 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>  ;  

| From Gordon Charlton | https://www.facebook.com/groups/PROGRAMMINGFORTH/permalink/2142203446079678/
: 'if ( b xt xt --?) >r over and swap 0=I r> and or xeq ; | 20190713
 

| /\ OPERATORS /\ ============================================ /\
." /\\ ops /\\ " cr

." \\/ fns \\/ "  $.s cr

| \/ FUNCTIONS \/ ============================================ \/

variable indentv   : indent indentv @ spaces ; 
: lstitm  indent execute cr ; 
: lst ( list -- )	| display the contents of a nested list   
	 dup @ 0if ( LIST ) indent ." ( " cr indentv ++ ['] lst eachM ."  )" indentv -- ;then   
	 dup @ TypeI  =if ['] I. lstitm ;then
	 dup @ TypeC  =if ['] C. lstitm ;then
|	 dup @ TypeS  =if ['] S. lstitm ;then
	 dup @ TypeFl =if { sigdig @ s>f _f rnd F.  } lstitm ;then

|	 dup @ TypeV  =if ['] v. lstitm ;then
|	 dup @ TypeA  =if ['] a. lstitm ;then
|	 dup @ TypeFv =if ['] fv. lstitm ;then

	 dup @ _n     =if drop indent ."  _n " ;then
     drop indent ." ( " ." nonce " ."  )" ; 
 
: o ( list -- list ) | show CoSy obj leaving unchanged . useful for debugging
	dup refs+> dup lst refs-ok ; 
 
: oo over o drop o ; 	| show top 2 items on stack . 

: -1* ( nv -- nv ) dup @ TypeFl =if -1. _f *f ;then
   dup @ TypeI =if i-1 *i ;then
   ref0del z" must be numeric " throw ; 

: mem>iv ( adr n -- obadr )     | copy n cells from memory to IV
  dup intVecInit >r> 0 ix swap cells move r> ; 

        | : si ( n - i# n )  0 ?do i loop ;    | Stack Iota ; 

: &  ( I0 -- I1 )   | for each item of I0 return val n reps of corresponding
| index .  Example |  i( 0 0 0 1 0 1 0 3 1 )i & |>| 3 5 7 7 7 8  |
    	| ( Arthur Whitney def of ' where , and even his symbol )
        | example of use of extended def ( from Marco Pescosolido , soln to EE McDonnell's
    	|  K finger exercises # 39  )
    	|  x[|>&y]  reverse subsets , EEMD : "infixes" , of lengths  y  of list x .
    dup i# 0if int> ;then 	| simply return if empty | 20200406 | 20200407 forced int 
    refs+>
    dup @ TypeI <>if refs- z" & : arg must be integer " throw then    
    dup i# 0if refs- ei ;then
    dup ['] + across >_  -1 >aux  intVecInit >aux 	| 20200802 
    dup i# 0 ?do dup i i@ 0 ?do j aux@  auxx> 1+ >auxx>  i! loop
			  loop refs- aux> aux> drop  ; 

| ( i n -- bool of length n with 1s at i ) sort of inverse of ' & | 20190211  
: i>b >_ : _i>b intVecInit >aux> i1 --cba at! aux> ; 

: (' _n ; 
: ') s_n>ev  ; 	| make list of executed items . see 20180420
 
: ')i s_n>iv ; 	| make a list of XTs as int list . See 20250118
 
: Xeq >_ xeq ; 	| Execute list of XTs | 20250118 

|  eg: | ('  20180406.0724 _f  ` PSBT  ` BH  165.54 _f  s" auto"  ') 
|  Compiles fine | 20190818 |

: rev : reverse ( v -- r )	| 0 1 2 3 -> 3 2 1 0 	| added ` rev alias 20250416.1535
  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 ; 

| eg: | i( 0 1 2 3 4 )i 2 _rotate |>| i( 2 3 4 0 1 )i | | 20250621 added 3 letter abreviations
: Rot : rotate >_ : _Rot : _rotate ( v n -- v )		
   >aux dup v#@ VecInit
    dup @ if ( SIMPLE ) dup i#
     over Type@ TypeFl =if 0 ?do over i aux@ + i@ dup i i! loop 
               else 0 ?do over i aux@ + i@ over i i! loop  then 
	 else ( LIST ) dup i# 0 ?do over i aux@ + i@ refs+> over i i! loop then
   auxdrop swap ref0del ; 

: sublist ( lst i0 i1 -- lst )	| returns substring from i0 to i1 - 1
  2dup >if Head# drop z" sublist : i0 must not be greater than i1 " throw ;then 
  over - >aux> 2 pick @ VecInit >aux	| lst i0
  over swap ix aux@ vbody auxx> aux@ Ibytes *  move
  aux@ v?refs+ 
  | aux@ @ 0if aux@ i# 0 ?do aux@ i i@ refs+ loop then 
  ref0del aux> ; 

: _take ( v n -- r )		| APL take / reshape , just lists 
   ?dup 0if 0 over Type@ VecInit swap ref0del ;then | n = 0 , return empty 
	over i# 0if drop ref0del fnnm  "  : nonce : empty , needs prototype "
	 		strcat zt throw ;then 
   dup abs 2 pick @ VecInit >aux 
   over i# aux@ i# <if		| n > # v
     dup 0 <if 0 swap else 0 then	| if n neg , 0 n  do 
     ?do dup i i@ aux@ i i! loop  
    else	| 
	 --aab 0 <if dup vbytes + Head# cells + aux@ vbytes - aux@ van move 
     else vbody aux@ van move then 
   then aux@ v?refs+ ref0del aux> ; 

: ,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 ; 

: cLsimple ( la ra -- r ) | except for symbols 
  i#i# + over Type@ VecInit >aux
  over van >r> aux@ vbody >r> swap move 
  dup van r> r> + swap move 2ref0del aux> ; 

: 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 ; 	

| Kludge fix of bug in Reva  ' search on some strings 
: search ( a1 n1 a2 n2 -- a3 n3 true | false ) 
   prior search 00; over 0 <if cr ." search error " $.s cr 3drop 0 then ; 

| \/ filterd to chars )| 256 _iota |( from C:\4thCoSy\src\reva.f
: lc ( c -- c' ) dup 65 90 between if $20 or then ;  
| \/  copied from  C:\4thCoSy\lib\string\misc unchanged  .
: strlwr ( a n -- a n ) 2dup bounds do i c@ lc i c! loop noop ; 
: lower ( str -- str ) | convert string to lower case 
  dup vdup dup van strlwr 2drop swap ref0del ;   

: uc dup 97 122 between if $df and then ; 
: strupr ( a n -- a n ) 2dup bounds do i c@ uc i c! loop noop ; 
| : upper 1p> .. dup van strupr 2drop 1P> ; 	| 20180915
: upper 1p> van strupr _str 1P> ; | convert string to UPPER case | 20200530 |

| String Search . Returns indices of all occurences of S1 in S0 
| modeled on K _ss function 
| ' ssc is case sensitive . ' ss  is not . 
: ss ['] lower on2 : ssc ( S0 S1 -- IV )  2p 
   L@ i# 0if 2P 0 _iota ;then  | if L empty return empty 
   L@ vbody >aux L@ i# intVecInit >aux	| stk : ; aux : L.va res  
   L@ van -1 /string 	| L.va -1 , L.i# +1 
   L@ i# 1+ 0do  1 /string R@ van search | L.i+ n- true | false 
      if over auxx@ - aux@ i ii!	| S1 S1a S1n S0+ n- 
       else aux> i _take auxdrop leave
      then loop 2P> ; 

: =c { ' =I each } aaply ; 	| = char ( Iverson logic ) 2 integer vecs | 20231205 | made atomic 
: <>c { ' <>I each } aaply ; 	| not equal ( Iverson logic ) 2 integer vecs | ditto /\ |

| ( str tok -- bool version of ' ssc ) | 20190211 | renamed 20200420.1926 |
: =tok over i# intVecInit >aux ssc i1  aux@ --bca at! aux> ; 

: _2takecalc ( i# n -- m )	>r> abs swap - 0 min r> sn * ; 
| computes parameter to convert a ` cut to a ` _take . 

: _cut\ _i : cut\ ( List Idxs -- CV )	| cuts string at Idxs , Arthur Whitney's def 
| Generally , partitions a list into sublists beginning at indices Idxs which must be a non-decreasing set of indices into List . e.g.: 
|   s" atari" i( 0 3 )i cut 
| ( s" ata"
|   s" ri" )
| 
| Note that number of items in the result equals the count of Idxs , and that to retain the leading portion of a list , Idxs must start with 0 . Any repeated indices will produce empty items in the result .
| A single item ix will essentially "drop" that many items from the beginning of List . As a special case , a single negative ix will drop that many items from the tail of List . e.g.:
|  i( 1 2 3 4 )i i( -1 )i  _
| (
|  ( 1 2 3 )
| )
  2refs+> | single ix cases 
   dup i# dup 0if drop 2refs- ev ;then		| index empty -> empty
     1- 0if dup 0 i@ 0if refs- enc ;then	| index 0 return original , ref +ed 
     over i# over 0 i@ _2takecalc 2 pick swap _take >r 2refs- r> enc ;then
	 		| other single , take complement .
    dup i# dup cellVecInit >aux		| vec idxs	| real cut cases 
   1- 0 ?do --aaa i i@ swap i 1+ i@	| str Idxs a0 a1
   		3 pick -rot sublist refs+> aux@ i i! loop
   2dup -1 i@ over i# sublist refs+> aux@ -1 i!
  2refs- aux> ;    
 
: _cut _i : cut ( v i -- v ) | discloses if singlton index 
  dup i# >r cut\ r> 1 =if dsc then ; 
 
alias: _ cut 	| The K name .
 
: 0cut i0 swap cL cut ; | same as ' cut but includes portion before 1st cut   

: partition >_ : _partition ( v n -- v ) | cuts v into n parts .	| ` modernized 20241028 
| if v i# not multiple of n , last portion will contain the remainder .
   --aba i# --aba / _i $ 1- _take i0 $ ,I ' + scanI _ ; 

| APL reshape . eg : |  i( 1 0 -1 0 )i i( 3 3 )i take |
: take ( v idxs -- v ) | Note : modulo indexing .
    dup i# 0if refs- ;then 	| if index empty just returns | added 20200409 |
    ' * scanI >aux> -1 i@ _take  aux> i-1 cut reverse >aux>  
    i# 0 ?do aux@ i i@ _partition loop auxdrop ; 
 
| like singleton ' take , but repeats last element of v if y rho i < |
| for neg i repeats 0th char . 
| A useful variant from K.CoSy . See 20180506 
| like singleton ' take but fleshes out with last item 
| generalized to take negative arg 20190313 .
| Youtube | https://youtu.be/jJZUg_Hzkf8 | 
: _fill _i : fill ( l n -- l ) 
  dup 0 i@ 0 >if 2p L@ L@ rho i1 -i R@ iota mini at 2P> ;then 
   >r reverse r> -1*i fill reverse ; 
 
| K | fill : { :[ 0< x ; y[ ( ! x ) & -1 + # y ] ; | _f[ - x ; | y ] ] }

: nsplt ( lst n -- lst )  2p L@ # R@ %i R@ cL L@ $ take 2P> ; 	| splits LA into pieces n long | 20240817

: fmtI ( Iv -- Str )	| format integers . returns list of each number 
	| converted to a string .
   dup i# cellVecInit >aux>
   i# 0 ?do dup i i@ (.) str refs+> aux@ i i! loop
   ref0del aux> ; 
 
: fmtnI ( Iv n -- Str )  >_ >aux { >_ aux@ (.r) _str } 'm auxdrop ;  
| formats right justified in n chars . fixed for change from use of ' i@ to _at 
| in ` each fns | 20200314

: fmtI$ hex fmtI decimal ; 
: fmtI% binary fmtI decimal ; 	| format binary . Reva uses % as tag for binary | 20201129
 
: fmtF ( Fv -- Str )	| format floats . returns list of each number 
	| converted to a string .
   dup i# cellVecInit >aux>
   i# 0 ?do dup i i@ sigdig @ (f.) str refs+> aux@ i i! loop
   ref0del aux> ; 
 
: fmtnF >_ : _fmtnF ( f precison -- strs ) sigdig xchg >r fmtF r> sigdig ! ; 

: fmtF18 18 _fmtnF ; 	| max precision 	| 20190417 

0 [IF]
: fmt ( v -- str )	| format numbers . returns list of each number 
	| converted to a string .
	dup @ dup TypeC and if drop ;then	| if already char , return .
	dup TypeI and if drop fmtI ;then
	dup TypeFl and if drop fmtF ;then
	ref0del drop z" nonce" throw ; 
[THEN] 	| See ' lst for simpler ' fmt |

: filter ( la ra fn -- r )	| applies bool fn to la and ra returning true items
	2 pick refs+> >r each & r@ swap at\ r> refs- ; 

: braket ( str strs -- str ) 2p> 0 _at swap cL R@ 1 _at cL 2P> ; 
| Prefixes and suffixes str with 2 item strs . Examples :  
|      s" 2 item"  s" <i>" s" </i>" ,L braket
|  s" <i>2 item</i>"
|     s" /4thCoSy/CoSy/Furniture.f "  s"  | " enc braket
|  s"  | /4thCoSy/CoSy/Furniture.f  | " 
|     i( 5 6 5 )i 4 _i braket
|  4 5 6 5 4 

| Evaluate strings of ints or floats | 20201222.2056 |
: iEval  s" i( "  s"  )i " ,L braket  Eval ; 	| 20211009 remove foolish final ' _i 
: fEval  s" f( "  s"  )f " ,L braket  Eval ; 

: tokcut ( str tok -- CV )	| cuts string at occurrences of string `tok but includes segment before first token 
  2p LR@ ssc i0 swap ,I L@ swap cut 2P> ; 
 
: toksplt ( str tok -- CV )	
| like ' tokcut but deletes the tokens from the cut pieces .
| Note , empty tok will return empty .
| 20190124 replaced ' cut w ' cut\ .  
   2p LR@ swap cL >aux+> dup R@ ssc cut\ 	| appends tok at front then cuts 
   aux- R@ rho ['] cut eachleft  2P> ; 
 
| Finessing bomb on 0 occurrences of tok . See Mon.Mar,20170306 |
| : toksplt 2p> swap cL R@ prior toksplt 1 _cut 2P> ; 

| 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_lf ) "lf VM ;
 
: htVM ( str -- list_of_strings_split_on_tab ) "ht VM ; 


| ' 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> ; 

|  2p L@ R@ 0 i@ ss dup i# 0if L@ 2P> ;then 
|  R@ 1 i@ ['] cL eachleft ,/ R@ 1 i@ rho -1*i cut 2P> ; 

| Quick ( to think ) and dirty . Could be highly optimized .

: 'd ( LA RA fn -- R ) 	| each dyadic . applies fn between each corresponding pair of LA and RA . add ` enc 20230728 |
   >r 2p r> LR@ longer_ ev swap 
   0 ?do L@ i _at R@ i _at l0@ execute enc cL loop 2P> ; 

: eachm ( RA fn -- R ) swap 1p ev >aux  | catinates 
   R@ i# 0do R@ i _at 2 SF@ execute aux> swap cL >aux loop
   1P drop aux> ; 

: enc' ['] enc eachm ;  | enc each ( 'm bombs on floats ) 

: cLr ( p0 l1 -- )		| catinate Lists , replace . 
  | note , for use in appending to dic , encloses second arg so treated as
  | one item . even if already nested list .
  over @ swap enc cL swap rplc ; 

: _nth ( CSob n -- CSadr )  	| extracts nth item from each item of CSob  
   _i 2refs+> ev  2 pick i# 0 ?do 2 pick i i@ 2 pick at\ cL loop >r 2refs- r> ;     		

: 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> ; 

| cconb ( strings str -- bool )	| returns bool where stings in LA contain RA 
| returns all 1s for empty str  | 20211129 | 
: cconb 2p R@ i# 0if i1 L@ # take 2P> ;then LR@ ' ssc 'L { i# sn _i } 'm ,/ 2P> ;  
 
: 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> ; 

cr cr  ." | /\ Fns /\ | \/ Dic \/ | Stk : "  $.s  cr cr 

." \\/ DICTIONARY  \\/ " $.s cr 
| \/ ============================================ \/
| | 20110814 | have determined that really do need explicit type . Was just 3 vec
| 20210727 | No I don't . Have never used .  Is just a list of 2 correlated lists .
| $006346964 value TypeDic		| " dic" 

| empty dictionary : 2 empty vecs . 

: () : ed ( -- emptyDic ) ev enc 2 _take ( TypeDic over Type! ) ; 	

 ed  refs+> value R 	 | initialize empty Root dictionary


: dicapnd ( val dic name -- )	| adds item to dictionary
   refs+> | dup name?_ 0if refs- ref0del ref0del z" invalid name " throw then
  swap >r> 0 ix swap cLr r> 1 ix swap cLr ; 


| `( Type0 TypeC TypeI TypeFl TypeS TypeV TypeA TypeFv )`

." /\\ DICTIONARY  /\\ ======/\\  " $.s cr

| match obj str , I-logic .
: strmatch_ ( s0 s1 -- 0|1 )	
  2dup van rot  van str= -rot 2ref0del ;  
: strmatch strmatch_ _i ; 

| Match 2 objects .  Returns 1 iff LA identical to RA .		| See 20230423 |
: match_ 2p ( la ra -- bool ) 
  LR@ =if 2P 1  ( ." same addr " cr ) ;then 	| refer to same object 
  LR@ Type@@ <>if 2P 0 ( ." ~= types " cr ) ;then 	| Types don't match 
  LR@ ' i# on2> <>if 2P 0 ( ." ~= rho " cr ) ;then 	| lengths don't match
   R@ i# 0if 1 2P_> ;then	| empties match
 R@ Type@ if | simple 
   R@ Type@ TypeC = if LR@ strmatch_  2P_> ;then
   R@ Type@ TypeI =if LR@ =i ' and acrossI >_ 2P_> ;then
   R@ Type@ TypeFl =if LR@ =f ' and acrossI >_ 2P_> ;then
 then  | Nested 
   R@ i# 0do L@ i i@ R@ i i@  match_ 0if  0 leave then loop
   dup if drop 1 then 2P_> ; 
 
: == : match match_ _i ; 
 
: where ( L v -- idx ) ' match f? ; 
| Index of first v in list L . count of L if not found . Equivalent to APL ` iota .
 
: memb ( L R -- bool ) over >a ['] where 'R ,/ a> rho <i ; 
| Bool of items of R which are in L | See 20180627 
 
: membv ( L R -- v ) 2p R@ L@ R@ memb & at\ 2P> ; 
| Items of R which are in L 
 
: ~memb memb 0=i ;  : ~membv  2p R@ L@ R@ ~memb & at\ 2P> ; 
| R not memb L  and items of R not in L . Note use of ' at\ | 20190502 
 
: venn  2p (' R@ L@ ~membv LR@ membv LR@ ~membv ') 2P> ; 
| returns list of 3 lists :  ( x nin y ; x in y ; y nin x ) 

 ." ` venn "  .s cr 

| return unique items .  Like  K's  ' ? 
: nubb 1p> R@ ' where 'R ,/ R@ rho iota =i 1P> ; | bool of 1st occurrences
: nubx nubb & ; 	| indices of 1st occurrences 
: nub 1p> dup nubx at 1P> ; 	| unique items .
: nnub 1p> dup nubb 0=i & at 1P> ; | redundants
 
| Group items by uniques | see Wed.Oct,20191002 | https://youtu.be/fxx9kS_seXk |
: grpib 1p> nub R@ ,/ ' =i 'L 1P> ; 	| group integer bool
: grpix grpib ' & 'm ;  		| group integer index
 
: grpcx >a> nub a> swap  ' conn 'R  ; 
 
| 20191008 | ` nubgrp optimized merge . Eliminates redundant call of ' nub 
: nubgrpib 1p> nub >a> R@ ,/ ' =i 'L a> swap ,L 1P> ; | nub & group integer bool
| and uses CoSy's access to addresses using ' ix rather than just ' i@ and ' i!
| to optimally replace just the second item in the result from ' nubgrpib
: nubgrpix nubgrpib >a> 1 ix dup @ ' & 'm swap rplc a> ; 
 
: nubgrpcx >a> nub a> swap >a> ' conn 'R a> swap ,L  ; 	| 20210625 
| /\ | Takes list . Returns 2 item list of `( nub grp )` .

| ( L R  --  nub sums ,L )
: aggrc nubgrpcx >a> 1th { at +/ } 'R a> dsc swap ,L ; 	| char version
: aggri nubgrpix >a> 1th { at +/ } 'R a> dsc swap ,L ; 	| int version 
| aggregate ( sum ) values L by nub of R . | 20210705 |

 ." ` aggr " .s cr

| returns index of first occurance of sym in list or _n if not found .
: ?str_ ( lst str  -- i | _n )	['] strmatch_ _f? ;   
 
: ?str ['] strmatch f? ; 

| returns index of first occurance of sym in dic names , else _n .
: (wheresym) ( dic sym -- i | _n )
   swap dsc swap ?str_ ; 
 
: wheresym (wheresym) _i ; 

| : symfind wheresym _n; dic 1 i@ swap ix ; 

| delete items at i from v |  Currently i must be sorted and unique .   
: dvi ( v i -- v )	
  2p L@ dup i# R@ i# - swap @ VecInit >aux 0 temp rp
  L@ R@ over i# 0 ?do dup temp @ i@ i <>if over i i@ aux@ i temp @ - i! 
  					else temp ++ then loop 2drop temp rP aux> dup v?refs+ 2P> ; 
	
| delete items at i from table of same length lists  , eg , a dictionary .      
: dti ( table i -- )  2p L@ dup 
	i# 0 ?do dup i ix dup @ R@ dvi swap rplc loop drop 2P ; 

| delete item named sym from dictionary .
: dts ( dic sym -- ) 2p> wheresym L@ swap dti 2P ; 

: dnames ( dic -- names ) 0 _at ;  : dvals 1 _at ; 

| \/ | look up symbol in dictionary , return address of corresponding val or _n 
: vx_ ( dic sym -- adr of value | _n )
    --aab (wheresym) dup _n =if nip ;then swap 1 i@ swap ix ; 

| : sx_ ( dic sym -- adr of symbol | _n ) 
|   --aab (wheresym) dup _n =if nip ;then swap 0 i@ swap ix ; 

: undefthrow  ( idx --  | throw ) dup _n =if drop z" undefined " throw then ; 

| fetch symbol associated with symbol in dictionary
| : s@ ( dic sym -- sym ) sx_ undefthrow @ ; 	

| 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 .

| store value associated with symbol in dictionary
: .v! : v! ( val dic sym -- )
	--bca ( dic sym val ) 2refs+> 2dup 2>aux --abcab vx_ 
	dup _n =if  drop --cab dicapnd 
	        else  rplc 2drop  then
	2aux> 2refs- ; 
 
: v! ( v D idx -- ) | store value generalized to list addr | 20180506        
      blVM swap >aux 2p L@ aux> R@ -1 _cut v@ R@ i-1 take dsc .v! 2P ; 	| 20230512
 
: v!> ( val dic sym -- dic ) over >a v! a> ; 

| copy value from one dictionary to another . 20180621
: vcopy ( d0 d1 v -- ) >a swap aux@ v@ swap a> v! ;  

 ." ` vcopy " .s cr
	
| fetch value ( which must be string ) and evaluate 
: v* ( dic sym -- result ) v@ van eval ; 

: >< ( sym val -- dic )		| creates dic with sym and val . 
	swap enc swap enc ,L ; 

: djoin ( dic dic -- dic )  { cL enc } 'd ; 
| catinates each list of pair of lists , eg , dictionaries . see 20180218 .

: symrplc ( dic oldsym newsym -- )
  >r swap 0 i@ --bba  ?str_   dup _n =if 2drop z" undefined " throw then
   ix r> swap rplc ; 

: TaddCol ( mat proto -- mat ) | Adds a list of prototype to a table of equal length lists .;  
 2p> $ dsc # take enc' enc L@ $ cL 2P> ; 	| 20231105.2017

: vdel ( dic sym  -- ) | deletes entry from dictionary
    2p> (wheresym) dup _n =if drop 2P ;then
    _i refs+> 
	dup L@ 0 ix dup @ rot dvi swap rplc 
	dup L@ 1 ix dup @ rot dvi swap rplc 
	refs- 2P ; 
 ." ` vdel " .s cr 

| : vdel 2p> encatom { prior vdel L@ } Y./ 2P> drop ; | extended to multiple deletions
| added to ./CoSy/CoSy.f | 20200910 

: dsel ( dic syms -- dic ) | returns dic of items named in list syms .
   2p R@ R@ { L@ swap v@ } eachM> ,L 2P> ; 

."  /\\ dic /\\  ---  E o Script | "  .s cr  

needs Furniture.f	| Furniture : fns to flesh out the living area not dependent on ` R dic

cr ." \\/ RESTORE \\/  " $.s cr 	| =============== |

 " COSYSTARTFILE" getenv str />\ >value CoSyStartFile  | 20200227 | 20210411 | 
 CoSyStartFile dup s" \" ss -1 _at i1 +i take >value CoSyDir
: FullCoSyFile CoSyStartFile  s" ." prt<l ; 
: CoSyFile  FullCoSyFile s" \" toksplt -1 _at ; 

: bkuplast  | 20200614
  s" del " FullCoSyFile cL s" .bk" cL shell^  
  s" copy " CoSyStartFile cL "bl cL FullCoSyFile cL s" .bk" cL  shell^
; 
 ." pre-restore here : "  here . cr 

needs SaveRestore.f 	| FUNDAMENTAL : string >< reference counted list |

needs sort.f 	| might as well load this here | 20200902 |


| Reva takes first command line parameter as script to load , eg , this CoSy.f .
| By default this loads the  *.csy  dictionary named in COSYSTARTFILE
| environmental variable . 

| Reva takes first command line parameter as script to load , eg , this CoSy.f .
| By default this loads the  dictionary named in COSYSTARTFILE 
| environmental variable . . Normal default *.csy .
| If a second argument is present , it is loaded instead . 
| CoSyFile dsc o restorefile ' R rplc
 
 CoSyStartFile ." CoSyStartFile " o cr restorefile ' R rplc    

| restore | R R --> _R | neat line , but then R `. _R  is recursive catastrophe 
 
 cr ." /\\ RESTORE /\\  " .s cr 	| =============== |

: F>/\ F> str>lst ; 		| io of lists directly | 20200831 
: \/>F swap lst>str swap >F ; 	| fixed \/>F 20201230 

: >at!> rep dup at! ; 

 ." ` >at!> " .s cr

 R refs+> value _d
 
: Dnames _d dnames ; 

: Dwheresym ( str -- i | _n ) _d swap (wheresym) ; 

: Dvx_ ( sym -- adr of value | _n )	| takes symbol 
	| look up symbol in dictionary and return address of corresponding val or _n 
	_d swap vx_ ; 

: Dv@ ( sym -- val | error ) _d swap blVM ' v@ Y./ ;  

: Dv! ( val sym -- )	| Root variable store 
   _d swap v! ; 

: Dvdel _d swap vdel ; 

 ." ` Dvdel " .s cr

| append catinate ( ' cL ) object to list word in Dictionary . 20171114.
: v_cL ( val D s -- ) vx_ dup @ --bca cL swap rplc ;  
: Dv_cL ( val nm -- ) _d swap v_cL ; 

| Utility treed variable 
: >R0> dup : >R0 R ` R0 v! ; 
: R0 R ` R0 v@ ; 
 
: >R1> dup : >R1 R ` R1 v! ; 
: R1 R ` R1 v@ ; 


: >T0> dup : >T0  R ` T0 v! ; 
: T0 R ` T0 v@ ; 
 
: >T1> dup : >T1  R ` T1 v! ; 
: T1 R ` T1 v@ ; 


: >Fn> dup : >Fn R ` Fn v! ; 	| File name handle holder | 20200407 | | made persistent 20220430 20220508
: Fn R ` Fn v@ ;
 
: >Ft> dup : >Ft R ` Ft v! ; 	| File text handle holder | 20200407 |
: Ft R ` Ft v@ ; 


| cr ." start RecurInterp "  $.s cr
| needs RecurInterp.f
 
needs Derived.f
cr ." here "  $.s cr

| needs Head#change.f

| needs math/big

 needs Job.f  .s cr	| doesn't run right from w/i script0 

 ` script0 Dv@ Eval  	.s cr 

 ." Pre Tui : "  here . cr

needs Tui.f   .s cr

mark EoDefs

ev >R0 
 ." R0 " cr R0 DMP | 20180527
 
 
cr 
cr ." | eo CoSy.f "  $.s cr  here . cr

cr
." ( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) "
cr  here .  $.s cr
cr
 
0 [IF]
."  The CoSy \"TextualUserInterface\" is now loaded . Enter \"go\" to start . 
  Note that the CoSy \"APL\" vocabulary is available here
  in the regular console mode ."
cr cr
."  In this mode , the prompt has been redefined to output the stack
 in hex after every execution . "
 cr cr
 | ." To start the TUI , just execute \"go\" "
| cr cr
 [ELSE] 
." In case of crash , execute  'restart' at command prompt ." cr
." Execute 'restore' to replace CoSy.csy with backup CoSy.bk " cr cr
 
  CoSyStartFile lst .s cr  | 20210110 |
 ." loaded " .s cr 
   go 
 [THEN]
| ################################################### |

