needs lib/str lib/struct lib/time mem/reuse mem/sort
unit mem/timetbl

6 const BUCKETCNT
BUCKETCNT 8* const ROWSZ
60 const INTERVAL
create MULTIPLIERS map< , 1 10 60 1440 10080 -1

struct TimeTable {
  uint rowcnt ts rollovercnt lastidx lowesthits fmtvalwidth ;
  smethod fmtval ; \ ( n -- a u )
  [void,0] buf( ;
}

: rows( A! rowcnt 4* A> buf( + ;

: newtimetbl ( nrows -- tbl )
  here# over , now , 0 , -1 , 0 , 8 , ['] formathex , ( nrows tbl )
  swap ROWSZ 4+ * allot0 ;

: bucket ( idx tbl -- bucket )
  A! rowcnt over <= ?abort"bucket index out of range"
  ROWSZ * A> rows( + ;

: validx ( value tbl -- ?idx f ) bi buf( | rowcnt idx ;
: idxval' ( idx tbl -- a ) buf( swap 4* + ;

: alltime ( bucket -- n ) BUCKETCNT 1- 4* + @ ;
: tocol ( bucket idx -- a ) 4* + ;
: toprev ( a -- a ) BUCKETCNT 4* + ;

$100 ?reuse value sortbuf
: sorttbl ( colidx tbl -- a )
  r! rowcnt 8* doto sortbuf swap ?realloc | ( colidx V1=tbl )
  sortbuf V1 rowcnt 0 do ( colidx a )
    i V1 bucket oover tocol @ swap !+ ( colidx a+4 )
    i swap !+ loop ( colidx a )
  2drop sortbuf r> rowcnt sortpairs ( )
  sortbuf ;

: zerobucket ( bucket -- bucket ) dup BUCKETCNT 2* 0 fill ;
: freebucket ( tbl -- idx bucket )
  dup lowesthits not if
    dupbi lastidx 1+ | rowcnt < if
      doto lastidx 1+ dup | dup A> bucket zerobucket exit then then
  r! lastidx dup r@ bucket dup alltime r@ lowesthits > if ( idx bucket V1=tbl )
    2drop 5 r@ sorttbl ( a )
    @+ r@ to lowesthits @ dup r@ to lastidx ( idx )
    dup r@ bucket then rdrop zerobucket ;

: valbucket ( value tbl -- bucket )
  2dup validx if swap bucket nip else ( value tbl )
    r! freebucket ( value idx bucket V1=tbl )
    rot> r> idxval' ! then ;

code dorollover ( a u -- )
  PSP) A>) @+, begin \ W=u A=a
    0 i) S>) @, A) S>) @!, A) BUCKETCNT 4* +) S>) !,
    ROWSZ i) A>) +, 1 i) -, ?brnz, drop, exit,

code doerase ( a u -- )
  0 i) S>) @, PSP) A>) @+, begin \ W=u A=a S=0
    A) S>) !, A) BUCKETCNT 4* +) S>) !,
    ROWSZ i) A>) +, 1 i) -, ?brnz, drop, exit,

code ?rolloverat ( ts tbl -- )
  \ This is called often, implement a fast return path when no rollover
  W) offsetof ts +) A>) @, INTERVAL i) A>) +,
    PSP) A>) >) if, 2drop, exit, then pushlr, ]
  r! ts - INTERVAL / ( rollcnt )
  dup INTERVAL * r@ doto ts + | ( rollcnt )
  r@ doto rollovercnt tuck + dup | ( oldcnt newcnt )
  BUCKETCNT 0 do
    i 4* MULTIPLIERS + @ ( oldcnt newcnt mult )
    oover over / ( oldcnt newcnt mult olddiv )
    oover rot / ( oldcnt newcnt olddiv newdiv )
    swap- ?dup if ( newcnt oldcnt divdiff )
      V1 rows( i 4* + V1 rowcnt rot 1 = if dorollover else doerase then then
    loop 2drop rdrop ;

: ?rollover now swap ?rolloverat ;

code bucket++ ( a -- )
  BUCKETCNT i) A>) @, begin 1 W) +n, 4 i) +, 1 i) A>) -, ?brnz, drop, exit,

: hitbucketat ( idx ts tbl -- ) tuck ?rolloverat bucket bucket++ ;
: hitbucket now swap hitbucketat ;
: hitat ( value ts tbl ) tuck ?rolloverat valbucket bucket++ ;
: hit now swap hitat ;

: prorate ( val progress total -- n ) rot> * swap / ;
: retrorate dup rot - swap prorate ;

: progress ( columnidx tbl -- progress total )
  rollovercnt swap 4* MULTIPLIERS + @ ( cnt limit )
  tuck mod swap ;

: retroratedminute ( bucket timestamp tbl -- n )
  ts - dup INTERVAL >= if 2drop 0 exit then ( bucket elapsed )
  swap toprev @ swap 60 retrorate ;

: .11 ( n -- ) formatdec 11 rot> rtypeleft ;
: .sortedtimetbl ( nmax sortedpairs tbl -- )
  dup fmtvalwidth 1+ "Key" c@+ rtypeleft ( nmax pairs tbl )
  ."last min   ... 10m    ... hour   ... day    ... week   all time\n"
  r! rowcnt 8* + 4+ swap r> tuck rowcnt min 0 do ( a tbl )
    swap 8- tuck @ over bucket alltime not if 2drop unloop exit then ( a-8 tbl )
      over @ over idxval' @ over fmtval ( a tbl a u )
      oover fmtvalwidth 1+ rot> rtypeleft ( a tbl )
      over @ over bucket ( a tbl bucket )
      2dup now rot retroratedminute over @ + .11 ( a tbl bucket )
      BUCKETCNT 1- 1 do ( a tbl bucket )
        dup i tocol toprev @ ( a tbl bucket prevn )
        oover i swap progress retrorate ( a tbl bucket retron )
        over i tocol @ + .11 loop ( a tbl bucket )
      alltime .11 nl> loop 2drop ;

: .timetbl 5 over sorttbl swap .sortedtimetbl ;