Paste: monolithic lists

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

! monolithic lists
! singly linked, 2.25 word/entry
! one array, grows by 1/8 increase (grows about 6 times to double in size)

SYMBOL: ((last))

TUPLE: mlist
    { table initial: { ((last)) f } }
    { (count) initial: 0 }
    { last# initial: 0 }
    { free# initial: 0 } ;
    
TUPLE: mlist-cursor
    { (list) read-only }
    { (index) read-only } ;

! list protocol
GENERIC: count>> ( list -- n )
GENERIC: zero>> ( list -- cursor )
GENERIC: last>> ( list -- cursor )
GENERIC: <cursor> ( index list -- cursor )

! list-cursor protocol
GENERIC: value>> ( cursor -- value )
GENERIC: next>> ( cursor -- cursor )
GENERIC: last? ( cursor -- t/f )
! GENERIC: (>>value) ( value cursor -- ) ! this provokes runtime errors... bug ?
GENERIC: insert-after ( value cursor -- )
GENERIC: delete-next ( cursor -- )
GENERIC: list>> ( cursor -- list )
GENERIC: index>> ( cursor -- index )

: <mlc> ( mlist index -- mlc ) mlist-cursor boa ;
M: mlist <cursor> ( index mlist -- mlc ) swap <mlc> ;
M: mlist count>> ( list -- n ) (count)>> ;
: >>count ( mlist n -- mlist ) >>(count) ;

M: mlist-cursor value>> ( mlc -- value ) [ index>> 1+ ] [ list>> table>> ] bi nth ;
M: mlist-cursor next>> ( mlc -- mlc' ) [ list>> ] [ index>> ] [ list>> table>> ] tri nth <mlc> ;
M: mlist-cursor last? ( mlc -- t/f ) [ index>> ] [ list>> last#>> ] bi = ;
M: mlist-cursor index>> ( mlc -- index ) (index)>> ;
M: mlist-cursor list>> ( mlc -- list ) (list)>> ;

M: mlist-cursor (>>value) ( value mlc -- ) dup [ ] [ index>> 1+ ] [ list>> table>> ] tri* set-nth ;
: >>next ( mlc mlc' -- mlc ) swap dup [ [ index>> ] [ index>> ] [ list>> table>> ] tri* set-nth ] keep ;

: <mlist> ( -- mlist ) mlist new ;

M: mlist zero>> ( mlist -- mlc ) 0 <mlc> ;
M: mlist last>> ( mlist -- mlc ) dup last#>> <mlc> ;
: free>> ( mlist -- mlc ) dup free#>> <mlc> ;

: >>free ( mlist mlc -- mlist ) index>> >>free# ;
: >>last ( mlist mlc -- mlist ) index>> >>last# ;

: free ( mlc -- ) dup list>> free>> >>next [ list>> ] keep >>free drop ;

: grow ( mlist -- )
    [ table>> length dup 16 /i 1+ 2 * + f <array> ] keep
    [ table>> [ swap '[ [ _ nth ] keep _ set-nth ] ] keep length [0,b) swap each ] 2keep
    [ nip table>> ] [ swap >>table drop ] [ nip ] 2tri
    [ table>> [ length 2/ ] bi@ [a,b) <reversed> ] keep '[ 2 * _ swap <mlc> free ] each ;

: alloc ( mlist -- mlc ) 
    [ dup free>> index>> 0 = [ grow ] [ drop ] if ] keep
    dup free>> [ next>> >>free drop ] keep ;
    
M: mlist-cursor insert-after ( value mlc -- )
    [ list>> dup count>> 1+ >>count drop ] keep
    [ [ list>> alloc swap >>value ] [ next>> ] bi >>next ] keep swap >>next 
    dup last? [ [ next>> ] [ list>> swap >>last ] bi ] when drop ;

M: mlist-cursor delete-next ( mlc -- )
    [ list>> dup count>> 1- >>count drop ] keep
    [ dup next>> last? [ dup list>> swap >>last ] when drop ]
    [ next>> ] [ dup next>> next>> >>next drop ] tri
    free ;
    
: delete-next-safe ( mlc -- ) [ last? [ "last element" throw ] when ] keep delete-next ;

: >mlist ( seq -- mlist ) <mlist> zero>> swap [ swap [ insert-after ] [ next>> ] bi ] each list>> ;
: 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 ;