! Copyright (C) 2008 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors arrays sequences sequences.private fry math.ranges 
       combinators locals circular ;
IN: mlists

! monolithic lists
! singly linked, circular
! space: worst case (1 + 4/k)*(cell + ceil(log2(N/2)/8)) bytes/entry
! time: usual O(1) insert-after/delete-next
! elements have a reference and can be deleted by reference in O(k)

! %fixme: next-map should be a log2(N)+1 bit signed int array

TUPLE: mlist
    { next-map initial: { 1 } }
    { values initial: { } }
    { (count) initial: 0 }
    { last# initial: 1 }
    { free# initial: 1 } ;
    
TUPLE: mlist-cursor
    { (list) read-only }
    { (index) read-only } ;

<PRIVATE

TUPLE: mlist-vocab-dummy-slots value next free last count lazy-next ;

PRIVATE>

SLOT: value
SLOT: next
SLOT: free
SLOT: last
SLOT: count
SLOT: lazy-next

: <mlc> ( mlist index -- mlc ) swap mlist-cursor boa ;
: index>> ( mlc -- index ) (index)>> ;
: list>> ( mlc -- list ) (list)>> ;
M: mlist-cursor value>> ( mlc -- value ) [ index>> 2 - ] [ list>> values>> ] bi nth ;
M: mlist-cursor (>>value) ( value mlc -- ) dup [ ] [ index>> 2 - ] [ list>> values>> ] tri* set-nth ;
: last? ( mlc -- ? ) [ index>> ] [ list>> last#>> ] bi = ;
: first? ( mlc -- ? ) index>> 1 = ;
M: mlist-cursor next>> ( mlc -- mlc' ) lazy-next>> ;

: <mlist> ( -- mlist ) mlist new ;
: zero>> ( mlist -- mlc ) 1 swap <mlc> ;
M: mlist last>> ( mlist -- mlc ) [ last#>> ] keep <mlc> ;
M: mlist count>> ( list -- n ) (count)>> ;
M: mlist (>>count) ( mlist n -- mlist ) (>>(count)) ;

<PRIVATE

DEFER: (delete-next)

: unsafe-next>> ( mlc -- mlc' ) [ index>> 1- ] [ list>> next-map>> nth ] [ list>> ] tri <mlc> ;
: (next)>> ( mlc -- mlc' ) unsafe-next>> [ index>> abs ] [ list>> ] bi <mlc> ;
: set-lazy-deleted ( mlc -- ) [ (next)>> index>> ] [ [ neg ] [ list>> ] bi* <mlc> ] [ ] tri (>>next) ;
: lazy-deleted? ( mlc -- ? ) unsafe-next>> index>> 0 < ;
M: mlist-cursor lazy-next>> ( mlc -- mlc' )
    dup (next)>> lazy-deleted? [ [ (delete-next) ] [ lazy-next>> ] bi ] [ (next)>> ] if ;
M: mlist-cursor (>>next) ( next mlc -- ) 
    dup [ index>> ] [ index>> 1- ] [ list>> next-map>> ] tri* set-nth ;

M: mlist free>> ( mlist -- mlc ) [ free#>> ] keep <mlc> ;
M: mlist (>>free) ( mlc mlist -- ) [ index>> ] [ (>>free#) ] bi* ;
M: mlist (>>last) ( mlc mlist -- ) [ index>> ] [ (>>last#) ] bi* ;

! these constants balance O(k) average work for O(1+1/k) space overhead/entry
: alloc-rate ( -- value ) 8 ;
: delete-effort ( -- value ) 0 ;

: free ( mlc -- ) { [ list>> free>> ] [ (>>next) ] [ ] [ list>> (>>free) ] [ f swap (>>value) ] } cleave ;

:: (grow) ( n mlist -- )
    mlist
    [ dup length n + swap resize ] [ change-values ] [ change-next-map ] bi
    next-map>> n tail-slice* [ from>> ] [ to>> ] bi [a,b) [ 1+ mlist <mlc> free ] each ;
    
: grow-count ( mlist -- n ) values>> length alloc-rate /i 1+ ;
: grow ( mlist -- ) [ grow-count ] keep (grow) ;
    
: alloc ( mlist -- mlc )
    [ dup free>> first? [ grow ] [ drop ] if ] keep
    dup free>> [ (next)>> >>free drop ] keep ;

: (delete-next) ( mlc -- )
    {
        [ dup (next)>> last? [ dup list>> swap >>last ] when drop ]
        [ (next)>> ] ! order is important
        [ dup (next)>> (next)>> >>next drop ]
    } cleave free ;

: change-list-count ( mlc quot -- mlc ) over list>> [ count>> swap call ] keep (>>count) ; inline

PRIVATE>
    
: insert-after ( value mlc -- )
    [ 1+ ] change-list-count
    [ [ list>> alloc swap >>value ] [ next>> ] bi >>next ] keep swap >>next 
    dup last? [ [ next>> ] [ list>> swap >>last ] bi ] when drop ;

: delete-lazy ( mlc -- ) 
    [ delete-effort [ next>> ] times drop ] keep [ 1- ] change-list-count set-lazy-deleted ;
: delete-next ( mlc -- ) 
    [ last? [ "last element" throw ] when ] keep [ 1- ] change-list-count (delete-next) ;

: >mlist ( seq -- mlist )
    {
        [ length 1+ [1,b] 1 circular boa >array ] ! next-map
        [ >array ]                                ! values
        [ length ]                                ! count
        [ length 1+ ]                             ! last#
        [ drop 1 ]                                ! free#
    } cleave mlist boa ;
    
: list>cursors ( list -- seq ) 
    zero>> next>> V{ } clone [ '[ [ next>> ] [ _ push ] [ last? not ] tri ] loop ] keep nip ;
: list>sequence ( list -- seq ) 
    zero>> next>> V{ } clone [ '[ [ next>> ] [ value>> _ push ] [ last? not ] tri ] loop ] keep nip ;
: list>indexes ( list -- seq ) 
    zero>> next>> V{ } clone [ '[ [ next>> ] [ index>> _ push ] [ last? not ] tri ] loop ] keep nip ;

: mlist-contract ( mlist -- seq ) list>sequence >mlist ;

<PRIVATE

: >mlist-proper ( seq -- mlist ) <mlist> zero>> swap [ swap [ insert-after ] [ next>> ] bi ] each list>> ;
: list>sequence-proper ( list -- seq ) list>cursors [ value>> ] map ;
: list>indexes-proper ( list -- seq ) list>cursors [ index>> ] map ;

PRIVATE>