! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays math kernel accessors sequences sequences.private
deques ;
IN: unrolled-lists

: unroll-factor 32 ; inline

<PRIVATE

MIXIN: ?node
INSTANCE: f ?node
TUPLE: node { data array } { prev ?node } { next ?node } ;
INSTANCE: node ?node

PRIVATE>

TUPLE: unrolled-list
{ front ?node } { front-pos fixnum }
{ back ?node } { back-pos fixnum } ;

: <unrolled-list> ( -- list )
    unrolled-list new
        unroll-factor >>back-pos ; inline

ERROR: empty-unrolled-list list ;

<PRIVATE

: <front-node> ( elt front -- node )
    [
        unroll-factor 0 <array>
        [ unroll-factor 1- swap set-nth ] keep f
    ] dip [ node boa dup ] keep
    dup [ (>>prev) ] [ 2drop ] if ; inline

: normalize-back ( list -- )
    dup back>> [
        dup prev>> [ drop ] [ swap front>> >>prev ] if
    ] [ dup front>> >>back ] if* drop ; inline

: push-front/new ( elt list -- )
    unroll-factor 1- >>front-pos
    [ <front-node> ] change-front
    normalize-back ; inline

: push-front/existing ( elt list front -- )
    [ [ 1- ] change-front-pos ] dip
    [ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline

M: unrolled-list push-front*
    dup [ front>> ] [ front-pos>> 0 eq? not ] bi
    [ drop ] [ and ] 2bi
    [ push-front/existing ] [ drop push-front/new ] if f ;

M: unrolled-list peek-front
    dup front>>
    [ [ front-pos>> ] dip data>> nth-unsafe ]
    [ empty-unrolled-list ]
    if* ;

: pop-front/new ( list front -- )
    [ 0 >>front-pos ] dip
    [ f ] change-next drop dup [ f >>prev ] when >>front
    normalize-back ; inline

: pop-front/existing ( list front -- )
    [ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
    [ 1+ ] change-front-pos
    drop ; inline

M: unrolled-list pop-front*
    dup front>> [ empty-unrolled-list ] unless*
    over front-pos>> unroll-factor 1- eq?
    [ pop-front/new ] [ pop-front/existing ] if ;

: <back-node> ( elt back -- node )
    [
        unroll-factor 0 <array> [ set-first ] keep
    ] dip [ f node boa dup ] keep
    dup [ (>>next) ] [ 2drop ] if ; inline

: normalize-front ( list -- )
    dup front>> [
        dup next>> [ drop ] [ swap back>> >>next ] if
    ] [ dup back>> >>front ] if* drop ; inline

: push-back/new ( elt list -- )
    1 >>back-pos
    [ <back-node> ] change-back
    normalize-front ; inline

: push-back/existing ( elt list back -- )
    [ [ 1+ ] change-back-pos ] dip
    [ back-pos>> 1- ] [ data>> ] bi* set-nth-unsafe ; inline

M: unrolled-list push-back*
    dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi
    [ drop ] [ and ] 2bi
    [ push-back/existing ] [ drop push-back/new ] if f ;

M: unrolled-list peek-back
    dup back>>
    [ [ back-pos>> 1- ] dip data>> nth-unsafe ]
    [ empty-unrolled-list ]
    if* ;

: pop-back/new ( list back -- )
    [ unroll-factor >>back-pos ] dip
    [ f ] change-prev drop dup [ f >>next ] when >>back
    normalize-front ; inline

: pop-back/existing ( list back -- )
    [ [ 1- ] change-back-pos ] dip
    [ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
    drop ; inline

M: unrolled-list pop-back*
    dup back>> [ empty-unrolled-list ] unless*
    over back-pos>> 1 eq?
    [ pop-back/new ] [ pop-back/existing ] if ;

PRIVATE>