immutable.red

; proof of concept (but usable!) implementation of immutable persistent 'blocks' in Red
; author: Jay G. Porcasi (@numberjay)
; the exported API is at the bottom, starting with: set '<function name> ...
; free to use without any warranty of any kind: use at your own leisure and risk
; for bugs, suggestions, questions... comment here below or reach me on Gitter (@numberjay)
; copyright Jay G. Porcasi 2017

context [

; all functions ending with ' are helper functions working on 'immutable' blocks only
; all functions ending with ! destructively mutate their argument

branching-level: 5 ; any level from 0 (linear) to n ((2^n)-ary tree)
branching-factor: does [2 ** branching-level]

dec: function [n] [n - 1] ; decrement
inc: function [n] [n + 1] ; increment

rem: function [n] [n and dec branching-factor] ; bit masking for fast remainder
quot: function [n] [shift n branching-level] ; bit shifting for fast quotient

start: 2 ; position of 'pointer' to first element of block
end: 3 ; position of 'pointer' to last element of block

tag: <_IBLOCK_> ; arbitrary tag to mark our immutable blocks

ilength?': function ["return number of items in immutable block"
                     iblock [block!]] [ ; difference between end and start pointers gives number of elements in block
                     iblock/:end - iblock/:start] 

pick-deep: function ["like pick, but for nested blocks (takes a path or block of indexes instead of an index)"
                     series [series!] path [block! path!]] [
                     get to path! compose [series (path)]]
                     
; poke-deep: function [series path value] [set to path! compose [series (path)] value series] ; actually not needed here

index->path: function ["maps a (linear) index to a (tree based) 'path' (block of indexes)"
                       index [integer!]] [
                       case [zero? index [copy []]
                             zero? q: quot index [append copy [] rem index]
                             zero? r: rem index [append index->path dec q branching-factor]
                             'else [append index->path q r]]]

path->slot: function ["given a path returns the index of the tree that contains the element at the path"
                      path [block!]] [
                      end + length? path]

ipick-one': function ["like pick, for immutable blocks"
                     iblock [block!] index [integer!]] [
                     if 0 < index and (index <= ilength?' iblock)
                        [pick-deep iblock/(path->slot p: index->path index + iblock/:start)
                                   p]]

ipick-one: function ["like pick but works for both mutable and immutable blocks"
                     block [block!] index [integer!]] [
                     unless index <= 0
                            [either immutable? block
                                    [ipick-one' block
                                                index]
                                    [pick block
                                          index]]]

singleton?: function ["true if series of exactly one element"
                      series [series!]] [
                      unless empty? series [empty? next series]]

poke': function ["like poke but returns the block instead of the value"
                 block [block!] index [integer!] value] [
                 poke block
                      index
                      value
                 block]
       
ipoke!': function ["mutable poke for tree based blocks"
                   root [block!] path [block!] value] [
                   either (i: first path) > length? root ; need to append?
                          [either singleton? path ; no need to navigate?
                                  [append/only root
                                               value]
                                  [append/only root
                                               ipoke!' copy []
                                                       next path
                                                       value]]
                          [either singleton? path
                                  [poke' root
                                         i ; first path
                                         value]
                                  [ipoke!' pick root
                                                i ; first path
                                           next path
                                           value
                                   root]]]
            
ipoke': function ["immutable poke for tree based blocks"
                  root [block!] path [block!] value] [
                  either (i: first path) > length? root: copy root ; need to append?
                         [either singleton? path ; no need to navigate?
                                 [append/only root
                                              value]
                                 [append/only root
                                              ipoke' copy []
                                                     next path
                                                     value]]
                         [either singleton? path
                                 [poke' root
                                        i ; first path
                                        value]
                                 [poke' root
                                        first path
                                        ipoke' pick root
                                                    i ; first path
                                               next path
                                               value]]]

out-of-range-error: function ["causes an out of range error"
                              index [integer!]] [
                              poke []
                                   index
                                   0]

ipoke-one!: function ["(mutable) poke that works for both mutable and immutable blocks"
                      block [block!] index [integer!] value] [
                      either 0 < index
                             [either immutable? block
                                     [either index <= ilength?' block
                                             [ipoke!' block/(path->slot p: index->path index + block/:start)
                                                      p
                                                      value
                                              block]
                                             [out-of-range-error index]]
                                      [poke' block
                                             index
                                             value]]
                             [out-of-range-error index]]

ipoke-one: function ["(immutable) poke that works for both mutable and immutable blocks"
                     block [block!] index [integer!] value] [
                     either 0 < index
                            [either immutable? block: copy block
                                    [either index <= ilength?' block
                                            [block/(s): ipoke' block/(s: path->slot p: index->path index + block/:start)
                                                               p
                                                               value
                                             block]
                                            [out-of-range-error index]]
                                     [poke' block
                                            index
                                            value]]
                            [out-of-range-error index]]

ipoke!: function ["extends ipoke-one! by also accepting paths and blocks of indexes for nested (mutable) pokes"
                  block [block!] path [integer! path! block!] value] [
                  case [integer? path [ipoke-one! block
                                                  path
                                                  value]
                        empty? path [value]
                        empty? next path [ipoke-one! block
                                                     first path
                                                     value]
                        'else [ipoke-one! block
                                          first path
                                          ipoke! ipick-one block
                                                           first path
                                                 next path
                                                 value]]]

bump-end!: function ["(destructively) increment the end pointer by 1 (default) or by n (end pointer will never go below 0 even for negative n)"
                     iblock [block!] /by n] [
                     iblock/:end: max iblock/:end + either by
                                                           [n]
                                                           [1]
                                      0
                     iblock]

iappend-one!: function ["(mutable) append of first element from (non empty) elems to immutable block"
                        iblock [block!] elems [block!]] [
                        bump-end! iblock
                        either root: iblock/(path->slot p: index->path iblock/:end) ; root exists?
                               [ipoke!' root
                                        p
                                        first elems
                                iblock]
                               [append/only iblock
                                            ipoke!' copy []
                                                    p
                                                    first elems]]

first-n: function ["(immutable) first n elements from elems"
                   elems [block!] n [integer!]] [
                   case [(zero? n) or empty? elems [copy []]
                         n = 1 or empty? next elems [reduce [first elems]]
                         'else [first parse elems
                                            [collect [keep n skip | keep thru end]]]]]
                  
iappend-many!: function ["(mutable) append of up to branching-factor elements from (non empty) elems to immutable block"
                         iblock [block!] elems [block!]] [
                         es: first-n elems
                                     branching-factor
                         either root: iblock/(path->slot p: index->path inc iblock/:end) ; root exists?
                                [ipoke!' root
                                         first-n p
                                                 (length? p) - 1
                                         es]
                                [append/only iblock
                                             ipoke!' copy []
                                                     first-n p
                                                             (length? p) - 1
                                                     es]
                          bump-end!/by iblock
                                       length? es]

partition: func ["groups elements of series (thanks to @greggirwin and @9214)"
                 series [series!] group [integer!]] [
                 case [any [empty? series not positive? group] [copy series]
                       group = 1 [collect [forall series
                                                  [keep/only reduce [first series]]]]
                       'default parse series
                                      [collect some [keep group skip | pos: keep (copy pos) thru end]]]]
                                     
                      
iappend-all!: function ["(mutable) append of all elements from (non empty) elems to immutable block"
                        iblock [block!] elems [block!]] [
                        len: length? elems
                        group: branching-factor
                        repeat _
                               length? index->path inc iblock/:end
                               [elems: partition elems
                                                 group]
                        roots: copy []
                        until [append/only roots
                                           first elems
                               elems: partition next elems
                                                group
                               empty? elems]
                        bump-end!/by append iblock
                                            roots
                                     len]

ones?: function ["true if block is empty or contains all 1's"
                 block [block!]] [
                 parse block
                       [any quote 1]]

iappend!': function ["(mutable) append of all elements from elems to immutable block, optimized for truly constant time per element"
                     iblock [block!] elems [block!]] [
                     case [empty? elems [iblock]
                           ones? index->path inc iblock/:end [iappend-all! iblock elems]
                           zero? rem iblock/:end [iappend!' (iappend-many! iblock elems) skip elems branching-factor]
                           'else [iappend!' (iappend-one! iblock elems) next elems]]]

iempty?': function ["true if immutable block is empty"
                    iblock [block!]] [
                    zero? ilength?' iblock]

iappend!: function ["extends (mutable) append to immutable blocks, optimized for truly constant time per element"
                    block [block!] value /only] [
                    either immutable? block
                           [case [only [iappend!' block reduce [value]]
                                  block? value [iappend!' block value]
                                  'else [iappend!' block reduce [value]]]]
                           [either only
                                   [append/only block value]
                                   [append block value]]]

iappend-one: function ["(immutable) append of first element from (non empty) elems to immutable block"
                       iblock [block!] elems [block!]] [
                       bump-end! iblock: copy iblock
                       either root: iblock/(s: path->slot p: index->path iblock/:end) ; root exists?
                              [iblock/(s): ipoke' root
                                                  p
                                                  first elems
                               iblock]
                              [append/only iblock
                                           ipoke' copy []
                                                  p
                                                  first elems]]


iappend-many: function ["(immutable) append of up to branching-factor elements from (non empty) elems to immutable block"
                        iblock [block!] elems [block!]] [
                        es: first-n elems
                                    branching-factor
                        iblock: copy iblock
                        either root: iblock/(s: path->slot p: index->path inc iblock/:end) ; root exists?
                               [iblock/(s): ipoke' root
                                                   first-n p
                                                           (length? p) - 1
                                                   es]
                               [append/only iblock
                                            ipoke' copy []
                                                   first-n p
                                                           (length? p) - 1
                                                   es]
                         bump-end!/by iblock
                                      length? es]

iappend-all: function ["(immutable) append of all elements from (non empty) elems to immutable block"
                        iblock [block!] elems [block!]] [
                        iappend-all! copy iblock
                                     elems]

iappend': function ["(immutable) append of all elements from elems to immutable block, optimized for truly constant time per element"
                    iblock [block!] elems [block!]] [ ; only the first append is immutable, the others are mutable and don't produce intermediate immutable blocks to GC (cfr. transients in Clojure)
                    case [empty? elems [copy iblock]
                          ones? index->path inc iblock/:end [iappend-all iblock elems]
                          zero? rem iblock/:end [iappend!' (iappend-many iblock elems) skip elems branching-factor]
                          'else [iappend!' (iappend-one iblock elems) next elems]]]
                          
empty-iblock: does [copy reduce [tag 0 0]] ; generates empty immutable block

atom?: function ["true for strings and non series"
                 x] [
                 (string? x) or not series? x]

comment flatten: function ["flattens ('un-nests') one level" ; commented out because not tail recursive and blows stack
                   blocks [block!]] [
                   case [empty? blocks [blocks]
                         'else [append copy first blocks
                                       flatten next blocks]]]

flatten: function ["flattens ('un-nests') one level" ; iterative version of above, stack friendly
                   blocks [block!]] [
                   case [empty? blocks [blocks]
                         'else [b: copy []
                                foreach block
                                        blocks
                                        [append b
                                                block]]]]

comment flatten-append: function ["the effect is to 'linearize' a tree based representation of a block" ; commented out because not tail recursive and blows stack
                          blocks [block!]] [
                          case [empty? blocks [blocks]
                                'else [append copy first blocks
                                              flatten flatten-append next blocks]]]

flatten-append: function ["the effect is to 'linearize' a tree based representation of a block" ; iterative version of above, stack friendly
                          blocks [block!]] [
                          case [empty? blocks [blocks]
                                'else [i: 1
                                       b: copy first blocks
                                       until [block2: second blocks
                                              append b
                                                     repeat _
                                                            i
                                                            [block2: flatten block2]
                                              i: i + 1
                                              blocks: next blocks
                                              empty? next blocks]
                                       b]]]

to-immutable': function ["makes a mutable block into immutable (shallow, not deep)"
                         block [block!]] [
                         iappend!' empty-iblock block]
                    
to-mutable': function ["makes an immutable block into mutable (shallow, not deep)"
                       iblock [block!]] [
                       first-n skip flatten-append skip iblock
                                                        end
                                    iblock/:start
                               ilength? iblock]

ifirst': function ["like first but for immutable blocks"
                   iblock [block!]] [
                   ipick iblock
                         1]

bump-start!: function ["(destructively) increment the start pointer by 1 (default) or by n (start pointer will never go below 0 even for negative n)"
                       iblock [block!] /by n] [
                       iblock/:start: max iblock/:start + either by 
                                                                 [n]
                                                                 [1]
                                          0
                       iblock]

inext': function ["like next but for immutable blocks"
                  iblock [block!]] [
                  either iempty?' iblock
                  [iblock]
                  [bump-start! copy iblock]]

comment iskip': function ["like skip but for immutable blocks" ; this version would not allow prepending, not made my mind up yet
                  iblock [block!] offset [integer!]] [
                  either offset < ilength?' iblock
                         [bump-start!/by copy iblock
                                         offset]
                         [empty-iblock]]

iskip': function ["like skip but for immutable blocks" ; this version would allow prepending (iprepend) as many elems as previously skipped
                  iblock [block!] offset [integer!]] [
                         bump-start!/by copy iblock
                                        either offset < len: ilength?' iblock
                                               [offset]
                                               [len]]

ilast': function ["like last but for immutable blocks"
                  iblock [block!]] [
                  ipick iblock
                        ilength?' iblock]

imost': function ["returns all elements of an immutable block except the last (converse of inext')"
                  iblock [block!]] [
                  either iempty?' iblock
                  [iblock]
                  [bump-end!/by copy iblock
                                -1]]

show-count: 80 ; limit items to show when printing immutable structures at the console

ishow': function ["returns the first show-count elements of an immutable block as if it were mutable (hides the implementation)"
                  iblock [block!]] [
                  b: copy []
                  repeat i
                         min show-count
                             ilength?' iblock
                         [append/only b
                                      ipick-one' iblock 
                                                 i]]
                 
;;; public API follows:

set 'immutable? function ["true if value is an immutable block"
                          value] [
                          if block? value
                             [tag = first value]]

set 'ilength? function ["like length? but also works for immutable blocks"
                        block [block!]] [
                        either immutable? block
                               [ilength?' block]
                               [length? block]]

set 'ipick function ["like pick but also works with immutable blocks and accepts paths or blocks of indexes for nested 'picks'"
                     block [block!] path [integer! path! block!]] [
                     case [integer? path [ipick-one block
                                                    path]
                           empty? path [none]
                           empty? next path [ipick-one block
                                                       first path]
                           'else [ipick-one block
                                            first path
                                            ipick ipick-one block
                                                            first path
                                                  next path]]]

set 'ipoke function ["like poke but also works with immutable blocks and accepts paths or blocks of indexes for nested (immutable) 'pokes'"
                     block [block!] path [integer! path! block!] value] [
                     case [integer? path [ipoke-one block
                                                    path
                                                    value]
                           empty? path [value]
                           empty? next path [ipoke-one block
                                                       first path
                                                       value]
                           'else [ipoke-one block
                                            first path
                                            ipoke ipick-one block
                                                            first path
                                                  next path
                                                  value]]]

set 'iempty? function ["like empty? but also works with immutable blocks"
                       block [block!]] [
                       either immutable? block
                              [iempty?' block]
                              [empty? block]]

set 'iappend function ["like (immutable) append but also works with immutable blocks"
                       block [block!] value /only] [
                       either immutable? block
                              [case [only [iappend' block reduce [value]]
                                     block? value [iappend' block value]
                                     'else [iappend' block reduce [value]]]]
                              [either only
                                      [append/only copy block value]
                                      [append copy block value]]]

set 'to-immutable function ["converts a block to immutable (recursively if using /deep)" ; maybe should be /deep by default and use /shallow to limit to top level
                            value /deep] [
                            case [atom? value [value]
                                  empty? value [empty-iblock]
                                  deep [b: copy []
                                        to-immutable' foreach v
                                                      to-mutable value
                                                      [append/only b
                                                                   to-immutable/deep v]]
                                  immutable? value [value]
                                  'else [to-immutable' value]]]

set 'to-mutable function ["converts a block to mutable (recursively if using /deep)"
                          value /deep] [
                          case [atom? value [value]
                                empty? value [copy []]
                                deep [b: copy []
                                      foreach v
                                              to-mutable value
                                              [append/only b
                                                           to-mutable/deep v]]
                                immutable? value [to-mutable' value]
                                'else [value]]]

set 'ifirst function ["like first but also works with immutable blocks"
                      block [block!]] [
                      either immutable? block
                      [ifirst' block]
                      [first block]]

set 'inext function ["like next but also works with immutable blocks"
                     block [block!]] [
                     either immutable? block
                     [inext' block]
                     [next block]]

set 'ilast function ["like last but also works with immutable blocks"
                     block [block!]] [
                     either immutable? block
                     [ilast' block]
                     [last block]]

set 'imost function ["returns all elements of a mutable or immutable block except the last (converse of inext)"
                     block [block!]] [
                     either immutable? block
                     [imost' block]
                     [first-n block
                              dec length? block]]

set 'iskip function ["like skip but also works with immutable blocks"
                     block [block!] offset [integer!]] [
                     either immutable? block
                     [iskip' block
                             offset]
                     [skip block
                           offset]]

set 'ishow function ["shows an immutable block at the console as if it were mutable (hides the implementation)"
                     value] [
                     either atom? value
                            [value]
                            [value: either immutable? value
                                           [ishow' value]
                                           [first-n value
                                                    show-count]
                             b: copy []
                             either unset? foreach v
                                                   value
                                                   [append/only b
                                                                ishow v]
                                    [copy []]
                                    [b]]]

] ; end of context

bench-it: function ["utility function to show memory and time performance"
                    block [block!] /count ct [integer!]] [
                    ct: any [ct 1]
                    t: now/time/precise
                    loop ct [do []]
                    baseline-t: now/time/precise - t
                    s: stats
                    t: now/time/precise
                    loop ct [do block]
                    reduce [stats - s now/time/precise - t - baseline-t]]