:class var  
  cell bytes data
 :m !: ( n -- ) data ! ;m
 :m +: ( n -- ) data +! ;m
 :m @: ( -- n ) data @ ;m
 :m p: ( data ) data @ . ;m \ print self
;class


:class bool
  1 bytes bdata
  :m set: -1 bdata c! ;m
  :m clear: 0 bdata c! ;m
  :m @: ( -- flag ) bdata c@ 255 = ;m
  :m p: self @: . ;m
;class



0 [IF]
SEQUENCE is a generic superclass for classes which have multiple items which
frequently need to be looked at in sequence.  At present the main function of
Sequence is to implement the EACH: method, which makes it very simple to
deal with each element.  The usage is

 BEGIN  <obj> each:  WHILE <elem> (do something with the element)  REPEAT

Sequence can be a superclass for any class which implements the
FIRST?: and NEXT?: methods.  The actual implementation details are quite
irrelevant, as long as these methods are supported.

[THEN]

makeSelect next?: 
makeSelect first?: 



:class sequence 
 bool each_started?
:m each:  \ ( -- <varies> T  |  -- F )
  each_started? c@
  IF \ Subsequent time in:
   [self] next?: \ next?: is declared as a selector but there is no method yet
   IF  true  ELSE  0 each_started? c!  false  THEN
  ELSE \ First time in:       
   [self] first?: \ first?: is declared as a selector but there is no method yet
      0= IF 0 exit THEN
   -1 each_started? c!
   true  \ Yes, we've got the 1st element
  THEN ;m
:m uneach: \ Use to terminate an EACH: loop before the end.
  each_started? clear: ;m  \ could have used   0 each_started? c!
;class



:class dicPtr <super var
  var size \ size, in bytes, of memory allotted/allocated
  :m size: ( -- n )  size @ ;m
 :m new:  ( size -- ) \ size in bytes
    DUP ALIGN HERE SWAP ALLOT  self !  size ! ;m
;class



:class ptr <super var
 var size \ size, in bytes, of memory allotted/allocated
 :m size: ( -- n )  size @ ;m
 :m new:  ( size -- ) \ size in bytes
    DUP align ALLOCATE ?MEMERR  self !   size !: ;m
 :m free:
    self @ FREE ?MEMERR ;m
 :m resize:  ( newsize -- ) \ newsize in bytes
    self @ OVER RESIZE ?MEMERR  self !  size !  ;m
;class




makeSelect ^elem:

\ cellArray is a generic metaclass, meant only for subclassing
:class cellArray <super sequence
  var current

 :m to: ( n idx -- ) [self] ^elem: ! ;m
 :m +to: ( n idx -- ) [self] ^elem: +! ;m
 :m at: ( idx -- n ) [self] ^elem: @ ;m
 :m p: [self] size: 0 ?DO cr I DUP . self at: . LOOP ;m
 :m fill:  ( n -- )  [self] size: 0 ?DO DUP I self to: LOOP DROP ;m

 :m first?: ( -- elem t | f )
    0 current !
    0 [self] at: true ;m
  
 :m next?:  ( -- elem t | f )
  1 current +:   current @  dup  [self] size: <
  IF [self] at: true
  ELSE drop false
  THEN ;m

;class




\ cell size 1-dimension array, not resizable, alloted in the dictionary
\ but could also be cast as a heap object using heap>
:class dicArray <super cellArray cell <indexed
 :m ^elem: ( idx -- addr ) ^elem ;m 
 :m size: ( -- #elems ) limit ;m
;class



\ cell size 1-dimension array, dynamically resizable, allocated in heap
:class array <super cellArray
  var #elems
  ptr ardata
 :m size: ( -- #elems )  #elems @ ;m
 :m new: ( #elems -- ) DUP  #elems ! CELLS ardata new: ;m
 :m resize: ( n -- ) DUP  #elems ! CELLS ardata resize: ;m
 :m free:  ardata free:
    0  #elems ! ;m

 :m ?idx: ( idx -- idx )
    dup 
    0 #elems @: \ idx idx 0 #elems
    within IF exit THEN true ABORT" Index out of range" ;m
 :m ^elem: ( idx -- addr ) errorcheck IF self ?idx: THEN  CELLS ardata @  + ;m
;class




\ dynamically resizable string, allocated in the heap
:class string <super ptr

 :m new: ( addr len -- )
    DUP super new: ( addr len ) self @ SWAP ( addr self len ) MOVE ;m
 :m add: ( addr len -- ) \ add text to end of string
   DUP ( addr-src len len )
    size @ DUP >R + self resize:  \ addr-src len
   self @ R> + ( addr-src len dest) SWAP MOVE ;m
 :m @: ( -- addr len ) self @  size @ ;m
 :m p: self @: TYPE ;m
 :m +: ( char -- ) \ add char to end of string
     size @ 1+ self resize:   self @: + 1- c! ;m
;class

true value case-sensitive? \ used for searches in string+ objects

:class string+ <super string
\ We use the TextEdit metaphor of "selected" text with a starting position
\ for the selection START and an ending position END.  The positions are
\ zero-based and there will always be one more selection position than
\ the number of chars in the entire string.  For example:
0 [if]

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0
 h e l l o   w o r l d
            S
                      E
start=6  end=11  size=11

In the above START=6 and END=11 so the text "world" is selected.
We can say that the "w" belongs to position 6.  The SIZE of the
text is 11 chars.
There are 12 possible positions for both START and END ( 0 thru 11).
The last character in the string belongs to position 10.
[then]
  var start  \ selection start
  var end    \ selection end
  1 bytes theChar \ used for char searches
 :m reset: 0 start !  0 end !  ;m
 :m new: ( addr len -- ) super new:  self reset: ;m
 :m start: ( -- pos-addr ) start ;m
 :m end: ( -- len-addr ) end ;m
 \ the number of chars remaining after the selection
 :m rem: ( -- remainder ) size @ end @ - ;m
  
      
errorcheck [IF]
 :m ?idx: ( idx -- idx )
     dup 0 size @ within 0= IF TRUE ABORT" string+ index out of range" THEN ;m 
[ELSE]
 :m ?idx: ;m
[THEN]
 :m at: ( idx -- char )
     self ?idx:
     self @ + c@ ;m
 :m to: ( char idx -- )
     self ?idx:
     self @ + c! ;m
 :m upper: \ converts entire string to upper case
      self @: to-upper ;m
      
 :m @sub: ( -- addr len ) \ fetch substring
    self @ start @ + ( addr ) end @ start @ - ;m

\ case insensitive search
\ Do not invoke CIsearch: directly.  Rely on the case-sensitive? switch.
 :m CIsearch: ( addr len -- true | false )
    self heap: { addr len strobj }
    self @: strobj new: \ make a temporary duplicate string object in the heap
    strobj upper:  \ convert the duplicate to all upper case
    addr len to-upper \ convert search-for string to all upper case
    
        strobj @ strobj end: @ + ( start-addr) strobj rem: ( len )
           addr len search
        IF \ found
          ( u3 ) drop
          ( c-addr3 ) strobj @ - dup len + end ! start !
          true
        ELSE false
        THEN
        strobj <free \ dispose the temp string
   ;m

\ Search for given text starting at END
 :m search: ( addr len -- true | false )
    \ first do rationality check
    \ return false if len to find is greater than remainder
      dup self rem: > IF 2drop false exit THEN
      
    case-sensitive? 
    IF \ do case sensitive search
      { addr len }
      self @ end @ + ( start-addr) self rem: ( len)  addr len search
      IF \ found
        ( u3 ) drop
        ( c-addr3 ) self @ - dup len + end ! start !
        true
      ELSE  false
      THEN
    ELSE \ do case insensitive search
       self CIsearch:
    THEN
    ;m

:m chsearch: ( char -- flag )
   theChar c!  theChar 1 self search: ;m

 :m delete:  \ deletes the substring defined by START and END
             \ leaves START at the same place, END is set to START
     end @  start @ - 1 < IF exit THEN
     self @ end @ +   \ src 
     self @ start @ + \ src dest
     self rem: \ src dest cnt
     move
    size @  end @ start @ - -  self resize:
    start @ end !
     ;m

\ inserts text starting at END, START and END are moved to end of inserted text
 :m insert: { addr len -- } 
    size @ len + self resize:
    self @ end @ + dup ( src src ) len + ( dest ) self rem: ( cnt ) MOVE
    addr ( src ) self @ end @ + ( dest ) len MOVE
    end @ len + dup start ! end ! ;m

\ inserts char at END, START and END are moved to just past inserted char
 :m chinsert: ( c -- )
    theChar c!  theChar 1 self insert: ;m 
 
\ replace selected text, if any, with given text
 :m replace: ( addr len -- )
     self delete: self insert: ;m

\ Search for text1 starting at END.
\ If found replace with text2.
\ Success flag is returned.
 :m sch&repl:  { addr1 len1 addr2 len2 -- flag }
    addr1 len1 self search: dup
    IF addr2 len2 self replace: THEN ;m

\ Reset self and replaces all occurrences of (addr1 len1) by (addr2 len2)
\ in the WHOLE of self.  Self is lastly reset again.
 :m replall:  { addr1 len1 addr2 len2 -- }
 self reset:
 BEGIN
   addr1 len1 self search:
 WHILE
  addr2 len2 self replace:
 REPEAT
 self reset:
;m
    

 :m d:  \ formatted dump of string for debugging
   cr ."                     1                   2                   3                   4"
   cr ." 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0"
   cr  self size: 80 min 0 ?DO space i self at: emit LOOP
   cr start @ 42 min 2* spaces [char] S emit
   cr end @ 42 min 2* spaces [char] E emit
   cr ." start= " start p:  ."  end= " end p:  ."  rem= " self rem: . ."  size= " size p:
      ."   case-sensitive?= " case-sensitive? .
 ;m

 :m skipBlanks:
    BEGIN
      end @ size @ <> 
      end @ self at: 32 =  and
    WHILE
      1 end +!
    REPEAT
     end @ start ! ;m

\ CIword: must only be called by word:
:m CIword: { c -- flag }  \ handle case insensitive
    c lowerCase? IF c 32 - to c THEN
    BEGIN
      end @ size @ 1- > IF true exit THEN
      end @ self at: dup lowerCase? IF 32 - THEN
         c = IF true exit THEN
    true
    WHILE
    1 end +!
    REPEAT \ should never get here
    ;m      

\ Parse the string for text ending with char c.
\ Leading blanks are skipped.
\ Use @sub: to retrieve the substring if true is returned.
\ Subsequent use of word: will automatically advance past
\ the last "hit".
 :m word: { c -- flag }
    self skipBlanks:
    end @ size @ = IF false exit THEN
    case-sensitive? 0= IF c self CIword: exit THEN
    BEGIN
      end @ size @ 1- > IF true exit THEN
      end @ self at: c = IF true exit THEN
    true
    WHILE
    1 end +!
    REPEAT \ should never get here
    ;m      

;class


\ a (restricted resizeable) string that is alloted in the dictionary
\ although it could still be cast as a HEAP> object
:class xstring 1 <indexed
  var current \ current size

:m @: ( -- addr len )
    idxBase  current @ ;m
:m !: { addr len  -- }
     len limit > abort" xstring !: not enough room"
     addr ( src ) idxBase ( dest ) len MOVE
     len current ! ;m
:m add: { addr len -- }
   current @ len + limit > abort" xstring add: not enough room"
   addr ( src ) idxBase current @ + ( dest ) len MOVE
   len current +! ;m
:m +: ( char -- )
     current @ 1+ limit > abort" xstring +: not enough room"
     idxBase current @ + c!
     1 current +! ;m
:m p: ( -- ) self @: TYPE ;m
:m size: ( -- u )  current @ ;m
;class


:class ordered-col  <super dicarray
 var cursize    \ # elements in list
 
:m size: \ ( -- cursize )  Returns #elements currently in list
  cursize @  ;m

:m clear:
   0 super fill:  0 cursize ! ;m

:m add:  \ ( elem -- )  add elem to end of list
  cursize @ dup limit  =  ABORT" Ordered-col full"
  ( cursize ) super to:   1 cursize +:  ;m

:m last:  \ ( -- last )  Returns contents of end of list
   cursize @ dup 0= ABORT" Empty ordered-col"
    1-  super at:  ;m

:m delete:  \ ( indx  -- ) \ Removes the element at indx
     0 locals| cnt indx |
     cursize @  indx -  1-  to cnt
     cnt 0<  IF true ABORT" Can't delete: ordered-col"  THEN
     -1 cursize +:
     cnt  0= IF exit THEN
     indx  super ^elem: dup >r
     CELL+  r>  cnt CELL *  move ;m

\ Finds a value in a collection.
:m search:  \ { val -- indx T  | -- F }
    locals| val |
    self size: 0 ?DO i self at: val = 
        IF i unloop  true exit THEN
        LOOP false ;m

 :m map: { xt -- } \ apply xt to each element in the list
    BEGIN
      self each:
    WHILE
      xt execute
    REPEAT ;m

;class


\ ordered-col+ is modeled after the Smalltalk implementation
:class ordered-col+ <super ordered-col

:m first:  ( -- n )
 cursize @ 0= ABORT" Empty ordered-col"
 0 self at: ;m

:m addFirst: ( n -- ) \ adds n, makes n the first element in the array
 \ so add: is really an addLast:, but no need to change that
   cursize @  limit < 0=  ABORT" Ordered-col full" \ size check as for add: super
   cursize @ locals| idx |
   BEGIN
     idx 0>
   WHILE
     idx 1- dup to idx
     ( idx ) self at:  idx 1+ self to:
   REPEAT
 ( n ) 0 self to: \ place n at the begining
 1 cursize +: ;m  \ finally, increase current size by one

:m removeFirst: ( -- )
 0 super delete: ;m

:m set: ( <varies> cnt -- ) \ adds cnt items to collection
 \ example usage: 3 5 7 9 12  5 set: <myobj>
 0 ?DO self addFirst: LOOP ;m

:m sum: ( -- sum )
 0 BEGIN
  self each:
   WHILE
     +
   REPEAT ;m

:m max: ( -- max ) \ return maximum number in collection
     0 locals| max |
 BEGIN
  self each:
 WHILE
    dup max > IF to max ELSE drop THEN
 REPEAT max ;m

:m min: ( -- min ) \ return maximum number in collection
    self size: 2 < IF 1 < IF true ABORT" empty collection" THEN
                          0 self at: 
                   THEN
 1 self at: locals| min |  \ must start with something in min
 BEGIN
  self each:
 WHILE
    dup min < IF to min ELSE drop THEN
 REPEAT min ;m

:m removeAll: ( n -- ) \ remove all occurances of n from the list
    locals| n |
 BEGIN
  n self search:
 WHILE
  super delete:
 REPEAT ;m

:m occurrencesOf: ( n -- cnt ) \ number of times n is in collection
 0 locals| cnt n |
 BEGIN
  self each:
 WHILE
  n = IF cnt 1+ to cnt THEN
 REPEAT cnt ;m

:m conform: ( xt -- flag ) \ test if all elements meet condition
    locals| xt |
 BEGIN
  self each:
 WHILE
  xt execute ( flag ) 0= IF self uneach:  false exit THEN
 REPEAT true ;m

\ NOTE: for accept: reject: and collect: we return a new collection.  The original
\ collection is unchanged. This new collection returned
\ will be nameless and dynamically allocated in the heap.  Thus if you use one 
\ of these methods, the resulting collection must eventually get a <FREE.

:m accept: ( xt -- ^obj ) \ return new collection of elements that pass test
 self size:  self heap: locals| newCol xt |
 BEGIN
  self each:
 WHILE
  dup xt execute ( flag ) IF ( passed test) newCol add: ELSE drop THEN
 REPEAT newCol ;m

:m reject: ( xt -- ^obj ) \ return new collection of elements that fail test
 self size:  self heap: locals| newCol xt |
 BEGIN
  self each:
 WHILE
  dup xt execute ( flag ) IF ( passed test) drop ELSE ( failed test) newCol add: THEN
 REPEAT newCol ;m

:m collect: ( xt -- ^obj ) \ transform each element for a new collection
 self size:  self heap: locals| newCol xt |
 BEGIN
  self each:
 WHILE
  xt execute  newCol add:
 REPEAT newCol ;m

;class

[DEFINED] floats
[IF]
:class fp
  1 floats  bytes rdata
:m !: ( F: r -- ) rdata f! ;m
:m @: ( F: -- r ) rdata f@ ;m
:m  +:  ( F: r -- ) rdata f@ f+ rdata f! ;m
:m  -:  ( F: r -- ) rdata f@ fswap f- rdata f! ;m
:m p: [self] @: f. ;m
;class
[THEN]


cr .( FMS+30 Class Library is Loaded )