« Paradigmes et langages non classiques 2014

IN: plnc2
USING: assocs continuations fry kernel math namespaces sequences vectors ;

! We will be using the standard namespaces, which are implemented as a stack
! of hashtables. If we wanted to reimplement it ourselves (with a single
! namespace), we could do it like this. We use the fact that H{ } creates
! a new hash table at compilation time, which maens that every call to
! namespace will return the same hash table which can be modified or queried.

! : namespace ( -- hash ) H{ } ;
! : get ( variable -- value/f ) namespace at ;
! : set ( value variable -- ) namespace set-at ;
! : change ( variable quot: ( x -- x ) -- )
!     [ [ get ] keep ] dip dip set ; inline

! Now, we implement a counter using the namespaces words. SYMBOL: declares
! a name which pushes itself onto the stack.

SYMBOL: counter

: init-counter ( -- ) 0 counter set ;
: next-counter ( -- n ) counter [ [ 1 + ] change ] [ get ] bi ;

! We can use a continuation, created with callcc0, to create a counter which
! can be incremented while the rest of the application is executed again.

SYMBOL: my-ints*

: my-ints ( -- n ) init-counter [ my-ints* set ] callcc0 next-counter ;
: advance ( -- n ) my-ints* get continue ;

! We can create several independent counters by naming them.

: create-counter ( variable -- n )
    V{ 0 } clone swap '[ _ set ] callcc0
    [ [ pop 1 + ] keep push ] keep first ;

: advance-counter ( variable -- n ) get continue ;

! The angelic (or ambiguous) operator allows to select between various
! possibilities: the first one is selected, and if fail is called, the
! next one will be used, until there are no more alternatives. Of course,
! amb constructs may be stacked.

SYMBOL: fail*

: fail ( -- * ) fail* get continue ;

: reset ( -- )
    t [ fail* set drop f ] callcc0
    [ "No more alternatives" throw ] when ;

: amb ( seq -- n )
    >vector reverse
    fail* get
    [ fail* set ] callcc0
    over empty?
    [
        fail* set drop fail
    ] [
        drop pop
    ] if ;

! bag-of uses the vectors mutability and the possibility to stack amb
! calls to gather all the possibilities returned by an arbitrary quotation.

: bag-of ( quot: ( -- x ) -- seq )
    V{ } clone
    [ [ call( -- x ) ] dip push fail ]
    [ nip ] bi-curry
    [ { t f } amb ] 2dip if ;