! 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: ( 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 ) : ( mlist index -- mlc ) mlist-cursor boa ; M: mlist ( index mlist -- mlc ) swap ; 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 ; 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 new ; M: mlist zero>> ( mlist -- mlc ) 0 ; M: mlist last>> ( mlist -- mlc ) dup last#>> ; : free>> ( mlist -- mlc ) dup free#>> ; : >>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 ] 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) ] keep '[ 2 * _ swap 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 ) 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 ;