( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Associative Arrays [aka. Hash Tables] for Retro              )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Copyright [c] 2010, Marc Simpson                             )
( License: ISC                                                 )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( NOTE:                                                        )
( -----                                                        )
(                                                              )
( Since altering 'hash-prime' would affect previously written  )
( tables, we shall introduce the following condition: you may  )
( modify 'hash-prime' before creating hash-tables, but once    )
( this has been done, do NOT change its value afterward.       )
(                                                              )
( Of course, we could make 'hash' more flexible and have it    )
( read a prime value [or define a second word that respects a  )
( stack value for modding].  For now, let's just regard our    )
( stipulation as well justified; either tweak the provided     )
( hashing routines _before_ use, or leave them be.             )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )

include library/data/ll.retro
include library/data/hash.retro
include library/data/arrays.retro

' hashing open

( ~~[ Associative Array Vocab ]~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )

vocab associative
((
  : preallocate ( n- )
    ll.make ll:freelist !  for ll.make ll.free next ;

  1000 preallocate

  : new-hash   (   -t ) here hash-prime @ zallot ;
  : new-bucket ( $x-a ) here push swap , , pop ;

  : add-entry ( $xt- )
    push  over hash push new-bucket pop ( ah )
    pop ( aht ) + ( ae ) swap
    ll.new tuck ll.data !
    ( el ) over @ over ! ( next pointer )
    swap ! ;

  : get-entry (  $t-xf )
    over hash + @ ( $l )
    repeat dup 0 =if nip 0 ;then
    2dup ll.data @ @ compare if nip ll.data @ 1+ @ -1 ;then
    @ again ;

  {{
    : chop (  $-$ ) dup getLength + 1- 0 swap ! ;
    : (%{) ( "- ) char: = accept tib keepString dup chop ;
    ---reveal---
    : %{   ( "- ) compiler @ if ahead (%{) here rot ! literal,
                  else (%{) then ; immediate
  }}

  : }%   ( t$x- ) rot add-entry ;
  : @"   (  t"- ) compiler @ if
                  ahead " keepString here rot ! literal, else "
                  then ` swap ` get-entry ; immediate

  : 'type'   ( $- ) char: ' emit type char: ' emit space ;

  {{
    : bkt-keys ( l- ) repeat 0; dup 1+ @ @ , @ again drop ;
    : (keys)   ( t- ) hash-prime @ for @+ bkt-keys next drop ;
    ---reveal---
    : keys  ( t-a )
      here 0 , swap  (keys)  here over - 1- over ! ;
  }}

  : keys{ ( R: t- ) ` keys  ` dup ` push `  foreach{ ; compile-only
  : }keys ( R:  - ) ` }loop ` pop ` here ` - ` allot ; compile-only

  : .keys ( t-  )
    char: { emit space  keys{ 'type' }keys  char: } emit ;

  ( xyz -> xyzx: like 'rot', but _copies_ rotated item )
  : rover ` push ` over ` pop ` swap ; compile-only

  : .table ( t- )
    dup
    keys{ dup cr 'type' ." => " rover get-entry drop . }keys
    drop ;
))

' hashing shut
' associative shut