IN: inf355.cours2
USING: accessors arrays assocs combinators.smart continuations
       destructors fry infix io kernel locals make math namespaces
       sequences ;

! "call(" and "fry" illustration.

TUPLE: demo quot ;

: call-demo ( demo -- v )
    quot>> call( -- x ) ;

: add-gen ( a b c -- quot )
    [ [ + ] 2curry ]
    [ [ - ] curry ] bi* compose ;

: add-gen2 ( a b c d -- quot )
    '[ _ _ + _ @ ] ;

! Local variables and infix syntax. Most of the time, none of them is
! needed, but in some cases in may make the code clearer (e.g., when
! complex mathematical formulas are involved).

SYMBOL: myvar

:: delta ( a b c -- d )
    b b * a c * 4 * - ;

:: delta2 ( a b c -- d )
    [infix sq(b)-4*a*c infix] ;

:: delta3 ( a b c -- d )
    a b c 3array :> tab
    [infix sq(tab[1])-4*tab[0]*tab[2] infix] ;

:: example1 ( a b -- c d )
    a b :> ( c d ) c d ;

: example2 ( a b -- c )
    [let :> a :> b a b + ] ;

: example3 ( a b -- c )
    [let :> a a + ] ;

: delta4 ( a b c -- d )
    swapd [ sq ] [ 4 * ] [ * - ] tri* ;

! Destructors and object disposal. You can compare what happens when
! you raise an exception in "test-dispose" quotation.

TUPLE: myclass < disposable ;

M: myclass dispose*
    drop "Object disposal" print ;

: test-dispose ( -- obj )
    myclass new-disposable
    [ |dispose "Code execution" print ] with-destructors
    "End of code execution" print
    ;

! Let's implement Haskell like monads in Factor. Note for the readers:
! this has been done live in an interactive class session. This is
! probably not the best way to do it!

MIXIN: monad

! We use a "current-monad" variable to represent the context. It makes
! writing ">>=" easier since the monad won't be on the way to deeper
! stack values.

SYMBOL: current-monad

: with-monad ( monad quot -- monad )
    [ current-monad ] dip [ current-monad get ] compose with-variable ; inline

! The three monadic operations we will use are "fail", "return" and
! ">>=" (bind). Those will call generic words that can be overriden
! for individual monad classes. The current monad isn't used for
! "fail*" and "return*" but is needed to get proper dispatching.

GENERIC: fail* ( monad -- monad )
GENERIC: return* ( data monad -- monad )
GENERIC# >>=* 1 ( monad quot -- monad )

! By default, we may want to have a defaut "fail" behaviour if "fail*" is
! not overriden. However, here we do not want it.

ERROR: failure ;

! M: monad fail* failure ;

: fail ( -- )
    current-monad [ fail* ] change ;

: return ( data -- )
    current-monad [ return* ] change ;

:: >>= ( quot -- )
    current-monad [ quot >>=* ] change ;

! Data used for testing.

: telsdata ( -- hash )
    H{ { "Sam" "0661" }
       { "Julien" "0991" } } ;

: tels ( name -- )
    telsdata at [ return ] [ fail ] if* ;

! Implementation of the "maybe" tuple, corresponding to Haskell's maybe.
! Example use:
!
!   ( scratchpad ) "Julien" just [ [ tels ] >>= [ "Phone number is " prepend return ] >>= ] with-monad .
!   T{ maybe { set t } { data "Phone number is 0991" } }
!
!   ( scratchpad ) nothing [ [ tels ] >>= [ "Phone number is " prepend return ] >>= ] with-monad .
!   T{ maybe }
!
!   ( scratchpad ) "Claire" just [ [ tels ] >>= [ "Phone number is " prepend return ] >>= ] with-monad .
!   T{ maybe }


TUPLE: maybe
    { set boolean initial: f }
    data ;

: just ( data -- maybe )
    [ maybe new t >>set ] dip >>data ;

: nothing ( -- maybe )
    maybe new ;

: from-maybe ( maybe -- data )
    dup set>> t assert=
    data>> ;

INSTANCE: maybe monad

M: maybe fail*
    drop nothing ;

M: maybe return*
    drop just ;

M: maybe >>=*
    over set>>
    [
        [ from-maybe ] [ call( data -- ) ] bi* current-monad get
    ] [
        drop
    ] if ;

! A sequence may be a monad. Example use with the very same code:
!
!   ( scratchpad ) { "Julien" } [ [ tels ] >>= [ "Phone number is " prepend return ] >>= ] with-monad .
!   { "Phone number is 0991" }
!
!   ( scratchpad ) { "Claire" } [ [ tels ] >>= [ "Phone number is " prepend return ] >>= ] with-monad .
!   { }
!
!   ( scratchpad ) { "Julien" "Sam" } [ [ tels ] >>= [ "Phone number is " prepend return ] >>= ] with-monad .
!   { "Phone number is 0991" "Phone number is 0661" }

INSTANCE: sequence monad

M: sequence fail*
      { } swap like ;

M: sequence return*
    [ 1array ] [ like ] bi* ;

M: sequence >>=*
    [ call( x -- ) current-monad get ] curry map concat ;

! We could also say that any object is a monad, with "f" representing a failure. For that to work
! properly and not interact with sequences, we need to either comment out the "sequence is a monad"
! section or specialize it for only some kind of sequences.

! INSTANCE: object monad
!
! M: object fail* drop f ;
!
! M: object return* drop ;
!
! M: object >>=*
!     over [ call( x -- ) current-monad get ] [ drop ] if ;

! We can implement "do" which will bind every quotation in a sequence and return the result. Example use:
!
!  ( scratchpad ) { "Julien" "Sam" } { [ tels ] [ "Phone number is " prepend return ] } do .
!  { "Phone number is 0991" "Phone number is 0661" }

: do ( monad seq -- monad )
    [ [ >>= ] each ] curry with-monad ;

! "do*" will also execute each quotation, and "fail" if an exception is raised or "return" it if it
! doesn't. Example use:
!
!  ( scratchpad ) { 1 0 2 } { [ 1 swap / ] [ 2 + ] } do* .
!  { 3 2+1/2 }
!
!  ( scratchpad ) 1 just { [ 1 swap / ] [ 2 + ] } do* .
!  T{ maybe { set t } { data 3 } }
!
!  ( scratchpad ) 0 just { [ 1 swap / ] [ 2 + ] } do* .
!  T{ maybe }

: do* ( monad seq -- monad )
    [ '[ [ @ return ] [ 2drop fail ] recover ] ] map do ;