\
\ mark golden 

CR

.( I guess I can write anything I want as long as I put it in )

\   VOCABULARY CoSy    ALSO CoSy DEFINITIONS

\ --- \/  FLOORED MODULO FNS - from ansi standard  \/ ----

: /_MOD ( n1 n2 -- n3 n4) >R S>D R> FM/MOD ;   
: /_  ( n1 n2 -- n3)  /_MOD SWAP DROP ;
: _MOD ( n1 n2 -- n3)   /_MOD DROP ;
: */_MOD ( n1 n2 n3 -- n4 n5)  >R M* R> FM/MOD ;
: */_  ( n1 n2 n3 -- n4 )   */_MOD SWAP DROP ;

\ --- /\  FLOORED MODULO FNS - from ansi standard  /\ ----


: @+  @ 1+  ;   \ recommended by Charles Moore
                \  http://www.ultratechnology.com/rmvideo.htm 990522

: yn?  s"  [Y/N]: " type   key  dup emit  dup 121 = swap 89 = or ; 

: KB  0x1000 * ;
: MB  0x1000000 * ;

: ndrop  0 ?do  drop  loop ;

: s_ depth ndrop ;   \ Clear stack

: >>  $10 dump ;
: >>> $20 dump ;

: sn ( n -- -1|0|1 ) dup 0< swap 0> - ;         \ sign of n

: <sn ( n0 n1 -- -1|0|1 )  - negate sn ;        \ 1 iff n0 < n1 , -1 iff n0 > n1

: ~~  0<> negate ;              \ converts FORTH logic ( TRUE = -1 ) to
                                \ I-logic : Iverson logic ( TRUE = 1 )
: ~ 0= negate ;

2147483647 constant 0I
0I 1 + constant 0N

: hw! ( n adr -- )              \ store 16 bit value in hi word of cell
  2 + w! ;              \ not needed :   swap 10 lshift over w@ or swap ! ;

: hw@  @ hiword ; 

((    / commented out
: ~DO { n0 n1 | inc -- }  2dup - sign to inc    \ automatic inc , dec
   ?DO 
))

cr
.(  2003 12 17 4 37 40 )

\ | +stackmon

\ | : wv wview ; 

: .D  base @ >r decimal . r> base ! ;   \ . output decimal 

\ | : dt SYSTIME&DATE 6 0 DO U. LOOP ;

\ | : ldt TIME&DATE 6 0 DO U. LOOP ;

anew g1  \ ==================================== \

 s" nil" drop value nil

 s"  |) " drop value |)   
 s"  (>) " drop value (>) 
 s"  (| " drop value (|

8 constant byte

: alloc allocate abort" allocation failure " ;  ( bytes -- adr )

: oballoc 3 cells + aligned alloc ;  ( bytes -- addr )  \ allocate n bytes  + 3 cells
       \ header cells for ( type ; i# ( rho ) ; ( refs ; bits % cell ) )

  0 value buf  0 value bpos
: allocBuf 100 kb allocate abort" Buffer allocation failure " to buf
  0 to bpos ;

: freeA  free abort" free failure "  ;

((
: abortFree" ( adr F -- adr | free & abort )
  if free 1 abort" 
))

\ | ALIAS: ` addr

0 alloc value r1
: >r1 ( ob -- ob )      \ Temp handle holder . Frees old value when assigned new
   r1 freeA
   dup to r1 ;

0 alloc value r2
: >r2 ( ob -- ob )      \ Another Temp handle holder .
   r2 freeA
   dup to r2 ;

: rplc ( `p0 new -- )   \ free and replace pointer at `p0
  over @ freeA swap ! ;

: obbody ( obadr - obBodyAdr )
   3 cells+  ;

: `BnR 2 cells+ ;       \ top half of 3rd cell is item size in bits
                        \ bottom word of 3rd cell is reference count .

: bits! `BnR hw! ;
: bits@ `BnR hw@ ;

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

: refs+ `BnR 1 swap w+! ;
: refs- dup `BnR dup w@ 1 - dup         \ decrement refs & free if 0
  if swap w! else 2drop freeA then ;  


: cellVecInit ( n - objAdr )    \ make header and allocate space for n cells
   dup cells oballoc            ( n objAdr )
   dup cell+ rot swap !         \ # of items
   dup cell byte * over bits!   \ item size in bits 
   refs+ ;

 0 cellVecInit  value v0        \ empty vector 
 
 v0 value dic                   \ initialize dictionary
 
s" dic " drop value `dic

: i# ( adr -- number_of_items ) cell + @ ;  		\ APL  ` rho

: obsize ( addr -- n )  \ # bytes in whole object , aligned
   dup cell+ @ swap bits@ byte / * aligned 3 cells + ; 

: obdup ( adr -- newadr ) 
  dup obsize dup alloc dup >r swap cmove r> ;

: obparms                               \ # cells and address 
   dup cell+ @ over bits@ byte / *       ; 
 
: dataddr                               \ obbody , # bytes
   dup obbody swap dup i# swap bits@ byte / * ; 


: Idx    ( adr n -- adr of nth item in list ) \ modulo indexing
  over i# _mod over bits@ byte / * obbody + ;
  
: i@ idx @ ;   : i! idx ! ;     \ index fetch and store

: intVecInit ( n - objAdr )     \ make header and allocate space for int vec of length n
   cellVecInit
   dup -1 swap ! ;              \ integer vector type -1
                                \ ( too complex :  s" INTV" drop @
                                \ over ! )

: byteVecInit ( bytes - OA )    \ make header and allocate space for n bytes
   dup oballoc dup -8  swap !   ( n objAdr )  \ type vec of 8 bit items
   dup cell+ rot swap !         \ # of items
   dup byte over bits!          \ item size in bits
   refs+ ;


: str ( c-addr n -- OBadr )     \ store a string 
  dup byteVecInit dup >r        \ c-ad n Oadr
  obbody swap cmove r> ;


: sym                           \ symbol
   bl parse-word                ( c-addr len ) \ of next word
   dup aligned oballoc          ( c-addr len addr )
                                \  s" NAME" drop @ over !       ( c-addr len addr )
   dup >r 4 over !              \  symbol type 4
   2dup cell+ !                 \ c-addr len addr  \ # chars ( bytes ) stored
   dup byte over bits! refs+    \ 8 bit bytes .
   obbody swap cmove  r> ;

: enc     ( addr -- addr )      \ enclose
  1 cellVecInit swap over obbody ! ;

: ?enc ( lst -- Iflag )         \ return 1 if enclosed else 0
  @ ~ ;

: encatom ( CSob -- CSob )      \ Enclose iff not enclosed .
  dup @ 0<> 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 endif ;

: ~encabort ( CSob -- CSob )    \ Abort if not enclosed
  dup @ 0<> abort" not enclosed " ;

: dsc 0 i@ ;            \ disclose

: ,l ( O0 O1 -- O2 )    \ most basic catination of objects . Lisp like
  2 cellVecInit dup obbody dup
  4 pick swap ! 2 pick swap cell+ ! nip nip ;

: cL         { p0 p1 | n0 n1 adr -- adr }               \ catinate Lists
   p0 @ 0<> p1 @ 0<> or  if p0 @ p1 @ = abort" nonce " then

   p0 ?enc if  p0 i#  else  1  then to n0
   p1 ?enc if  p1 i#  else  1  then to n1

   n0 n1 + cellVecInit to adr
   p0 ?enc if  p0 dataddr adr obbody swap move
         else  p0 adr obbody !  then
  p1 ?enc if  p1 dataddr adr obbody n0 cells+ swap move
         else p1 adr obbody n0 cells+ ! then
   adr ;


: cLr ( `l0 p1 -- )             \ catinate lists , replace
  over @ swap  cL  rplc ;

((
: apnditem { lst itm | nwlst -- nwlst )  \ for enc lsts
   lst @ ~encabort
   obsize cell+ cellVecInit to lst      \ resize abort" resize failure " \ will likely fail
   cell+ incr dup i# 1-
))

\ : reasgn ( addr name vadr0 -- )       \

: iota ( n -- adr )
  dup intVecInit
  dup obbody rot                \  adr bodyadr n
  0 ?do i over i cells+ ! loop
  drop ;

: s>m ( n-items n addr - )              \ move n cells from stack to memory
  sp@ 2 cells+ swap rot cells cmove ;
 
: intVec ( n-items n -- oAdr )
  dup intVecInit dup >r obbody s>m r@ i# ndrop r> ; 

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

: acrossI  { obadr fn | n r -- res }    \ result returning "/" on integer lists 
   obadr i# to n  obadr obbody to obadr  0 to r
   n 0 ?do r obadr i cells+ @ fn execute to r  loop
   r ;

: across  { obadr fn | r -- r } \ result returning "/"
   \ obadr i#  abort" nonce : prototype " 
   obadr 0 i@ to r
   obadr i# 1 ?do r obadr i i@ fn execute to r  loop
   r ;

: eachM { CSob f -- }           \ `each Monadic , no result , eg , printing
   CSob i# 0 ?do CSob i i@     \ f CSob itemadr
   f execute  loop ;            \ f CSob 

: eachMr { CSob f CSadr -- CSadr }      \ `each Monadic resulting 
   CSob i# cellVecInit to CSadr
   CSadr i# 0 ?do CSob i i@            
    f execute CSadr i i! loop
   CSadr ; 
 
: eachRightR { LA RA f | AO -- AO }             \ eachRight resulting 
   RA i# cellVecInit to AO
   RA i# 0 ?do LA RA i i@              
    f execute AO i i! loop
   AO ;    

: nth ( CSob n -- CSadr )       \ `each Monadic resulting 
   over i# cellVecInit         \ CSob Result
   dup i# 0 ?do 2 pick i idx @ \ CSob Res itemadr
   2 pick idx @
   over i idx !                 \ CSob Res 
   loop nip nip ; 

: flip { CSob | nadr nbdy -- CSadr }    \ Transpose object . 
   CSob ~encabort  i#  0= if v0 else
   CSob 0 i@ i# cellVecInit dup to nadr obbody to nbdy
    nadr i# 0 ?do CSob i nth nbdy i cells+ ! loop nadr
   then ; 
 
((
: lst>dic ( lst -- dic )
  dup @ abort" not list "
  dup 0 i@ i# 2 3 within? 0= abort" must be # 2 or 3 "
  flip dup `dic swap ! ; 

: dic>lst ( dic -- lst )
  dup @ `dic <> abort" not dictionary "
  flip dup 0 swap ! ; 
))

: take { CSob n | s nwob -- nwob }              \ APL take / reshape
  n abs dup cellVecInit to nwob  n sn to s
   0 ?do CSob i s * i@ nwob obbody i cells+ !
     loop  nwob ; 

((
 : til ( ob fn -- n )
 0 1 0 2 0 1 depth nrev depth intvec >r1
))

: &  { I0 | I1 I1i -- I1 }   \ for each item of I0 return val n reps of corresponding index
    	\ ( 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 .
    \ I0 @ -1 <> abort" not int vec "
    I0 ['] + across intVecInit to I1  -1 to I1i
   I0 i# 0 ?do I0 i i@ 0 ?do j I1 +to I1i I1i i! loop
   loop I1 ;

: strmatch { s0 s1 -- 0|1 }     \ match obj str , I-logic .
  s0 dataddr s1 dataddr str= negate ;

: wheresym ( str dic -- i )
   0 i@ ['] strmatch eachRightR
   dup >r & r> freeA dup >r
   0 i@ r> freea ;

: Valadr ( str -- adr of value )
   dic wheresym dic 1 i@ swap idx ;

: v@ Valadr @ ;     : v! Valadr ! ;

((
: match1st  ( CSob -- flag )
  dup dscl
))

: So ( cadr u -- )      \ output string
   0 ?do i over + @ emit loop drop ;

: nameprnt ( CSadr -- )
  \ dup @ 4 <> abort" not name "
   dup 3 cells+ swap cell+ @ So ;

: namelst  cr nameprnt ;

: dnames ( dic -- ) 0 i@  ['] namelst eachM ;

((
: z ( ... Fadr0 Fadr1 -- ... )          \ compoZe , takes 2 fn tags
   >r execute r> execute ;              \ not clear worth anything

  \ : csasgn  ( adr ; name -- encVadr ) \ CoSy assign
  \   sym swap ,l enc ;

\ : csasgn ( adr ; name --

  : cs->  ( adr ; name --  ; dictionary entry )
     csasgn dic swap cl         \ newadr
    dic free abort" free failure "
    addr dic ! ;
))

: dicasgn { dic nm val -- }
  dic 0 idx  nm  cLr
  dic 1 idx  val  cLr ;

((
: cs->  ( adr ; name --  ; dictionary entry )
))

((
: cs-> { dic nm vl | t0 -- ; dictionary entry }
  BREAKPOINT
   dic 0 idx dup to t0  @ dup >r r@ nm cl t0 ! r> freeA
   dic 1 idx dup to t0  @ dup >r r@ vl cl t0 ! r> freeA ;

   dic sym .I  s" .R " str
))

((
   lst @ 0<> if lst obsize to n
              lst buff bufpos @ + n cmove
              bufpos dup @ n + swap ! exit then
   lst buff bufpos + 3 cmove
    bufpos dup @ 3 + swap !
   lst i# 0 ?do lst i idx @ recurse
   ;

 : walkleaves { lst fn | n -- }
   lst @ 0<> if lst
              lst buff bufpos @ + n .s cmove
              bufpos dup @ n + swap !
              exit then
   lst buff bufpos @ + 3 cells .s cmove
    bufpos dup @ 3 cells + swap !
   lst i# 0 ?do lst i idx @ recurse
              loop ;
))

 DEFER (storelst)
: storelst { lst -- clst cells }    \ convert allocated list to linear form
  allocBuf lst (storelst)
  buf bpos resize abort" resize failure "  bpos ;

 :noname { lst |  n -- }
   lst @ 0<> if lst obsize to n
              lst buf bpos + n cmove
              bpos n + to bpos
              exit then
   lst buf bpos + 3 cells cmove
    bpos 3 cells + to bpos
   lst i# 0 ?do lst i idx @ recurse
              loop ;
 is  (storelst)

   DEFER (rstrlst)
: restorelst ( clst -- lst )        \ convert linear form back to allocated
   buf >r to buf  0 to bpos (rstrlst)   \ memory tree structure
   r> to buf ;

 :noname { | n0 n1 lst -- lst }
     buf bpos + dup to n0 @             \  BREAKPOINT
      0<> if n0 obsize aligned to n1
       n1 alloc to lst
        n0 lst n1 cmove bpos n1 + to bpos lst
      else
       n0 i# dup to n1 cellVecInit to lst      \ item is type 0
       bpos 3 cells + to bpos
      n1 0 ?do recurse lst i idx !
     loop lst then ;
 is  (rstrlst)

: savelst ( lst c-adr n -- )    \ write list to file c-adr n
   r/w open-file abort" file error " >r
   storelst r@ write-file abort" file write error "
   r> close-file abort" file close error " ;

: readfile { | F Aob -- Aob }
  bl parse-word r/w open-file abort" File open error "  to F
  F file-size abort" File-size request error "
  abort" File too large "       \ 1st cell of D int non 0 .
  dup dup byteVecInit  dup to Aob  obbody       \
  rot f read-file abort" read-file error "
  f close-file abort" close-file error "
   <> abort" read length error "  Aob ;

: restorefile  readfile
  dup obbody restorelst swap freeA ;

: duplst ( lst -- nwlst )
  storelst drop dup restorelst swap freeA ;

\ restorefile c:\VFXFORTH\USER\dic.csy to dic

\ dic s" D:\MPEFORTH\VFXFORTH\USER\dic.csy" savelst

\ INTERPRETER \/ \/ \/ \



\ INTERPRETER \ /\ /\ /\ /\ \

\ | base @ decimal  CR ldt   base !

hex

cr  .( ln 469 )

anew C0


((              \ /\ END OF COMPILED SECTION /\

: lcd           \ from Forth Primer
begin
swap over mod \ body
dup 0= \ condition
until drop . ;

))
