77 lines
2.2 KiB
Factor
77 lines
2.2 KiB
Factor
|
! Copyright (C) 2008 Daniel Ehrenberg
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
USING: kernel accessors math qualified ;
|
||
|
|
QUALIFIED: sequences
|
||
|
|
IN: persistent.deques
|
||
|
|
|
||
|
|
! Amortized O(1) push/pop on both ends for single-threaded access
|
||
|
|
! In a pathological case, if there are m modified versions from the
|
||
|
|
! same source, it could take O(m) amortized time per update.
|
||
|
|
|
||
|
|
<PRIVATE
|
||
|
|
TUPLE: cons { car read-only } { cdr read-only } ;
|
||
|
|
C: <cons> cons
|
||
|
|
|
||
|
|
: each ( list quot -- )
|
||
|
|
over
|
||
|
|
[ [ >r car>> r> call ] [ >r cdr>> r> ] 2bi each ]
|
||
|
|
[ 2drop ] if ; inline
|
||
|
|
|
||
|
|
: reduce ( list start quot -- end )
|
||
|
|
swapd each ; inline
|
||
|
|
|
||
|
|
: reverse ( list -- reversed )
|
||
|
|
f [ swap <cons> ] reduce ;
|
||
|
|
|
||
|
|
: length ( list -- length )
|
||
|
|
0 [ drop 1+ ] reduce ;
|
||
|
|
|
||
|
|
: cut ( list index -- back front-reversed )
|
||
|
|
f swap [ >r [ cdr>> ] [ car>> ] bi r> <cons> ] times ;
|
||
|
|
|
||
|
|
: split-reverse ( list -- back-reversed front )
|
||
|
|
dup length 2/ cut [ reverse ] bi@ ;
|
||
|
|
PRIVATE>
|
||
|
|
|
||
|
|
TUPLE: deque { lhs read-only } { rhs read-only } ;
|
||
|
|
: <deque> ( -- deque ) T{ deque } ;
|
||
|
|
|
||
|
|
: deque-empty? ( deque -- ? )
|
||
|
|
[ lhs>> ] [ rhs>> ] bi or not ;
|
||
|
|
|
||
|
|
: push-left ( deque item -- newdeque )
|
||
|
|
swap [ lhs>> <cons> ] [ rhs>> ] bi deque boa ;
|
||
|
|
|
||
|
|
: push-right ( deque item -- newdeque )
|
||
|
|
swap [ rhs>> <cons> ] [ lhs>> ] bi swap deque boa ;
|
||
|
|
|
||
|
|
<PRIVATE
|
||
|
|
: (pop-left) ( deque -- item newdeque )
|
||
|
|
[ lhs>> car>> ] [ [ lhs>> cdr>> ] [ rhs>> ] bi deque boa ] bi ;
|
||
|
|
|
||
|
|
: transfer-left ( deque -- item newdeque )
|
||
|
|
rhs>> [ split-reverse deque boa (pop-left) ]
|
||
|
|
[ "Popping from an empty deque" throw ] if* ;
|
||
|
|
PRIVATE>
|
||
|
|
|
||
|
|
: pop-left ( deque -- item newdeque )
|
||
|
|
dup lhs>> [ (pop-left) ] [ transfer-left ] if ;
|
||
|
|
|
||
|
|
<PRIVATE
|
||
|
|
: (pop-right) ( deque -- item newdeque )
|
||
|
|
[ rhs>> car>> ] [ [ lhs>> ] [ rhs>> cdr>> ] bi deque boa ] bi ;
|
||
|
|
|
||
|
|
: transfer-right ( deque -- newdeque item )
|
||
|
|
lhs>> [ split-reverse deque boa (pop-left) ]
|
||
|
|
[ "Popping from an empty deque" throw ] if* ;
|
||
|
|
PRIVATE>
|
||
|
|
|
||
|
|
: pop-right ( deque -- item newdeque )
|
||
|
|
dup rhs>> [ (pop-right) ] [ transfer-right ] if ;
|
||
|
|
|
||
|
|
: sequence>deque ( sequence -- deque )
|
||
|
|
<deque> [ push-right ] sequences:reduce ;
|
||
|
|
|
||
|
|
: deque>sequence ( deque -- sequence )
|
||
|
|
[ dup deque-empty? not ] [ pop-left swap ] [ ] sequences:produce nip ;
|