modified: extra/prolog/prolog.factor
Gavin Harrison
parent
4fb5084de9
commit
053616dd63
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2007 Gavin Harrison
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel sequences arrays vectors namespaces math strings
|
||||
combinators continuations quotations io assocs ;
|
||||
|
|
|
|||
|
|
@ -1,91 +0,0 @@
|
|||
|
||||
USING: kernel sequences arrays vectors namespaces math strings
|
||||
combinators continuations ;
|
||||
|
||||
IN: prolog
|
||||
|
||||
SYMBOL: pldb
|
||||
SYMBOL: plchoice
|
||||
|
||||
: 2dupd ( x y z -- x y x y z ) >r 2dup r> ;
|
||||
|
||||
: init-pl ( -- )
|
||||
2 V{ } clone <array> pldb set
|
||||
V{ } clone plchoice set ;
|
||||
|
||||
: reset-choice ( -- ) V{ } clone plchoice set ;
|
||||
: remove-choice ( -- ) plchoice get pop drop ;
|
||||
|
||||
: facts ( -- vector ) 0 pldb get nth ;
|
||||
: rules ( -- vector ) 1 pldb get nth ;
|
||||
: fact ( n -- fact ) dup facts length >= [ drop "No." ] [ facts nth ] if ;
|
||||
: rule ( n -- rule ) dup rules length >= [ drop "No." ] [ rules nth ] if ;
|
||||
|
||||
: const? ( number/string -- ? )
|
||||
dup number? [ nip ]
|
||||
[ 0 swap nth dup CHAR: a >= swap CHAR: z <= and ] if* ;
|
||||
: var? ( number/string -- ? ) const? not ;
|
||||
: check-atom ( string -- ? ) const? ;
|
||||
|
||||
: check-fact ( list -- list ? )
|
||||
dup t
|
||||
[ {
|
||||
{ [ dup string? ] [ check-atom ] }
|
||||
{ [ number? ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond and ] reduce ;
|
||||
|
||||
: store-fact ( name fact -- ) 2array facts dup length swap set-nth ;
|
||||
|
||||
: add-fact ( name fact -- )
|
||||
check-fact [ store-fact ] [ drop " not valid" append print ] if ;
|
||||
|
||||
: add-choice ( continuation -- )
|
||||
dup continuation? [ plchoice get push ] [ drop ] if ;
|
||||
|
||||
: last-choice ( -- ) plchoice get pop continue ;
|
||||
|
||||
: extract-fact ( fact-entry -- fact ) dup string? [ 1 swap nth ] unless ;
|
||||
|
||||
: (lookup-fact) ( name num -- fact )
|
||||
dup fact dup "No." = >r 0 swap nth swapd dupd = swapd r> or
|
||||
[ dup fact [ ] callcc0 add-choice ] when
|
||||
dup number? [ 1+ (lookup-fact) ] [ 2nip extract-fact ] if ;
|
||||
|
||||
: check-arity ( pattern fact -- pattern fact ? ) 2dup [ length ] 2apply = ;
|
||||
|
||||
: (check-elements) ( fact pattern n ? -- ? )
|
||||
>r dup zero?
|
||||
[ 3drop r> ]
|
||||
[ 1 - dup -rot swap dup >r nth dup var?
|
||||
[ drop r> swap r> t and (check-elements) ]
|
||||
[ >r dupd dup >r swap nth r> r> swap >r = r> swap r> swap r> and swapd
|
||||
[ (check-elements) ] [ 3drop f ] if*
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: check-elements ( pattern fact -- ? ) swap dup length t (check-elements) ;
|
||||
|
||||
: match-pattern ( pattern fact -- ? )
|
||||
check-arity [ check-elements ] [ 2drop f ] if ;
|
||||
|
||||
: good-result? ( pattern fact -- pattern fact ? )
|
||||
2dup dup "No." = [ 2drop t ] [ match-pattern ] if ;
|
||||
|
||||
: lookup-fact ( name pattern -- fact )
|
||||
swap 0 (lookup-fact) good-result? [ nip ] [ last-choice ] if ;
|
||||
|
||||
: store-rule ( name pattern body -- ) 3array rules dup length swap set-nth ;
|
||||
|
||||
: add-rule ( name pattern body -- ) store-rule ;
|
||||
|
||||
: (lookup-rule) ( name num -- rule )
|
||||
dup rule dup "No." = >r 0 swap nth swapd dupd = swapd r> or
|
||||
[ dup rule [ ] callcc0 add-choice ] when
|
||||
dup number? [ 1+ (lookup-rule) ] [ 2nip ] if ;
|
||||
|
||||
! : (init-binds) ( pat-d pat-f binds limit pos -- pat-d pat-f binds limit pos )
|
||||
! -rot >r >r dup >r [ swap nth ] curry 2dupd 2apply
|
||||
|
||||
! : init-binds ( pat-d pat-f -- pat-d binds )
|
||||
|
||||
|
|
@ -1,93 +0,0 @@
|
|||
|
||||
USING: kernel sequences arrays vectors namespaces math strings
|
||||
combinators continuations ;
|
||||
|
||||
IN: prolog
|
||||
|
||||
SYMBOL: pldb
|
||||
SYMBOL: plchoice
|
||||
|
||||
: 2dupd ( x y z -- x y x y z ) >r 2dup r> ;
|
||||
|
||||
: init-pl ( -- )
|
||||
2 V{ } clone <array> pldb set
|
||||
V{ } clone plchoice set ;
|
||||
|
||||
: reset-choice ( -- ) V{ } clone plchoice set ;
|
||||
: remove-choice ( -- ) plchoice get pop drop ;
|
||||
|
||||
: facts ( -- vector ) 0 pldb get nth ;
|
||||
: rules ( -- vector ) 1 pldb get nth ;
|
||||
: fact ( n -- fact ) dup facts length >= [ drop "No." ] [ facts nth ] if ;
|
||||
: rule ( n -- rule ) dup rules length >= [ drop "No." ] [ rules nth ] if ;
|
||||
|
||||
: var? ( pl-obj -- ? )
|
||||
dup string? [ 0 swap nth dup CHAR: A >= swap CHAR: Z <= and ] [ drop f ] if ;
|
||||
: const? ( pl-obj -- ? ) var? not ;
|
||||
|
||||
: check-atom ( string -- ? ) const? ;
|
||||
|
||||
: check-fact ( list -- list ? )
|
||||
dup t
|
||||
[ {
|
||||
{ [ dup string? ] [ check-atom ] }
|
||||
{ [ number? ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond and ] reduce ;
|
||||
|
||||
: store-fact ( name fact -- ) 2array facts dup length swap set-nth ;
|
||||
|
||||
: add-fact ( name fact -- )
|
||||
check-fact [ store-fact ] [ drop " not valid" append print ] if ;
|
||||
|
||||
: add-choice ( continuation -- ) plchoice get push ;
|
||||
|
||||
: last-choice ( -- ) plchoice get pop continue ;
|
||||
|
||||
: extract-fact ( fact-entry -- fact ) dup string? [ 1 swap nth ] unless ;
|
||||
|
||||
: (lookup-fact) ( name num -- fact )
|
||||
dup fact dup "No." = >r 0 swap nth swapd dupd = swapd r> or
|
||||
[ dup fact [ add-choice ] callcc0 ] when
|
||||
dup number? [ 1+ (lookup-fact) ] [ 2nip extract-fact ] if ;
|
||||
|
||||
: check-arity ( pattern fact -- pattern fact ? ) 2dup [ length ] 2apply = ;
|
||||
|
||||
: check-elements ( pattern fact -- ? )
|
||||
t [ over var? [ 2drop t ] [ = ] if and ] 2reduce ;
|
||||
|
||||
: match-pattern ( pattern fact -- ? )
|
||||
check-arity [ check-elements ] [ 2drop f ] if ;
|
||||
|
||||
: good-result? ( pattern fact -- pattern fact ? )
|
||||
2dup dup "No." = [ 2drop t ] [ match-pattern ] if ;
|
||||
|
||||
: lookup-fact ( name pattern -- fact )
|
||||
swap 0 (lookup-fact) good-result? [ nip ] [ last-choice ] if ;
|
||||
|
||||
: store-rule ( name pattern body -- ) 3array rules dup length swap set-nth ;
|
||||
|
||||
: add-rule ( name pattern body -- ) store-rule ;
|
||||
|
||||
: (lookup-rule) ( name num -- rule )
|
||||
dup rule dup "No." = >r 0 swap nth swapd dupd = swapd r> or
|
||||
[ dup rule [ add-choice ] callcc0 ] when
|
||||
dup number? [ 1+ (lookup-rule) ] [ 2nip ] if ;
|
||||
|
||||
: add-bindings ( pat-d pat-f binds -- binds )
|
||||
[ over var? over const? or
|
||||
[ 2drop ] [ swap 2array swap dup >r push r> ] if
|
||||
] 2reduce ;
|
||||
|
||||
: init-binds ( pat-d pat-f -- binds ) V{ } clone add-bindings >alist ;
|
||||
|
||||
: deep-replace ( binds seq -- binds seq' )
|
||||
[ dup var? [ over 2dup key? [ at ] [ drop ] if ]
|
||||
[ dup sequence? [ dupd deep-replace nip ] when ] if
|
||||
] map ;
|
||||
|
||||
: backtrace? ( result -- )
|
||||
dup "No." = [ remove-choice last-choice ] [ [ last-choice ] unless* ] if ;
|
||||
|
||||
: resolve-rule ( binds rules -- binds )
|
||||
[ deep-replace >quotation call backtrace? ] each ;
|
||||
|
|
@ -1,122 +0,0 @@
|
|||
|
||||
USING: kernel sequences arrays vectors namespaces math strings
|
||||
combinators continuations quotations io ;
|
||||
|
||||
IN: prolog
|
||||
|
||||
SYMBOL: pldb
|
||||
SYMBOL: plchoice
|
||||
|
||||
: 2dupd ( x y z -- x y x y z ) >r 2dup r> ;
|
||||
|
||||
: init-pl ( -- )
|
||||
V{ } clone V{ } clone 2array pldb set
|
||||
V{ } clone plchoice set ;
|
||||
|
||||
: reset-choice ( -- ) V{ } clone plchoice set ;
|
||||
: remove-choice ( -- ) plchoice get pop drop ;
|
||||
|
||||
: facts ( -- vector ) pldb get first ;
|
||||
: rules ( -- vector ) pldb get second ;
|
||||
: fact ( n -- fact ) dup facts length >= [ drop "No." ] [ facts nth ] if ;
|
||||
: rule ( n -- rule ) dup rules length >= [ drop "No." ] [ rules nth ] if ;
|
||||
|
||||
: var? ( pl-obj -- ? )
|
||||
dup string? [ 0 swap nth LETTER? ] [ drop f ] if ;
|
||||
: const? ( pl-obj -- ? ) var? not ;
|
||||
|
||||
: check-atom ( string -- ? ) const? ;
|
||||
|
||||
: check-fact ( list -- list ? )
|
||||
dup t
|
||||
[ {
|
||||
{ [ dup string? ] [ check-atom ] }
|
||||
{ [ number? ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond and ] reduce ;
|
||||
|
||||
: store-fact ( name fact -- ) 2array facts dup length swap set-nth ;
|
||||
|
||||
: add-fact ( name fact -- )
|
||||
check-fact [ store-fact ] [ drop " not valid" append print ] if ;
|
||||
|
||||
: add-choice ( continuation -- )
|
||||
dup continuation? [ plchoice get push ] [ drop ] if ;
|
||||
|
||||
: last-choice ( -- ) plchoice get pop continue ;
|
||||
|
||||
: extract-fact ( fact-entry -- fact ) dup string? [ 1 swap nth ] unless ;
|
||||
|
||||
: (lookup-fact) ( name num -- fact )
|
||||
dup fact dup "No." = >r 0 swap nth swapd dupd = swapd r> or
|
||||
[ dup fact [ ] callcc0 add-choice ] when
|
||||
dup number? [ 1+ (lookup-fact) ] [ 2nip extract-fact ] if ;
|
||||
|
||||
: check-arity ( pattern fact -- pattern fact ? ) 2dup [ length ] 2apply = ;
|
||||
|
||||
: check-elements ( pattern fact -- ? )
|
||||
[ over var? [ 2drop t ] [ = ] if ] 2all? ;
|
||||
|
||||
: match-pattern ( pattern fact -- ? )
|
||||
check-arity [ check-elements ] [ 2drop f ] if ;
|
||||
|
||||
: good-result? ( pattern fact -- pattern fact ? )
|
||||
2dup dup "No." = [ 2drop t ] [ match-pattern ] if ;
|
||||
|
||||
: lookup-fact ( name pattern -- fact )
|
||||
swap 0 (lookup-fact) good-result? [ nip ] [ last-choice ] if ;
|
||||
|
||||
: store-rule ( name pattern body -- ) 3array rules dup length swap set-nth ;
|
||||
|
||||
: add-rule ( name pattern body -- ) store-rule ;
|
||||
|
||||
: (lookup-rule) ( name num -- pat-f rules )
|
||||
dup rule dup "No." = >r 0 swap nth swapd dupd = swapd r> or
|
||||
[ dup rule [ ] callcc0 add-choice ] when
|
||||
dup number? [ 1+ (lookup-rule) ] [ 2nip ] if ;
|
||||
|
||||
: add-bindings ( pat-d pat-f binds -- binds )
|
||||
clone
|
||||
[ over var? over const? or
|
||||
[ 2drop ] [ rot dup >r set-at r> ] if
|
||||
] 2reduce ;
|
||||
|
||||
: init-binds ( pat-d pat-f -- binds ) V{ } clone add-bindings >alist ;
|
||||
|
||||
: replace-if-bound ( binds elt -- binds elt' ) over 2dup key? [ at ] [ drop ] if ;
|
||||
|
||||
: deep-replace ( binds seq -- binds seq' )
|
||||
[ dup var? [ replace-if-bound ]
|
||||
[ dup array? [ dupd deep-replace nip ] when ] if
|
||||
] map ;
|
||||
|
||||
: backtrace? ( result -- )
|
||||
dup "No." = [ remove-choice last-choice ]
|
||||
[ [ last-choice ] unless ] if ;
|
||||
|
||||
: resolve-rule ( pat-d pat-f rule-body -- binds )
|
||||
>r 2dup init-binds r> [ deep-replace >quotation call dup backtrace?
|
||||
dup t = [ drop ] when ] each ;
|
||||
|
||||
: rule>pattern ( rule -- pattern ) 1 swap nth ;
|
||||
: rule>body ( rule -- body ) 2 swap nth ;
|
||||
|
||||
: binds>fact ( pat-d pat-f binds -- fact )
|
||||
[ 2dup key? [ at ] [ drop ] if ] curry map good-result?
|
||||
[ nip ] [ last-choice ] if ;
|
||||
|
||||
: lookup-rule ( name pattern -- fact )
|
||||
swap 0 (lookup-rule) dup "No." =
|
||||
[ nip ]
|
||||
[
|
||||
dup rule>pattern swapd check-arity
|
||||
[ rot rule>body resolve-rule dup -roll binds>fact ] [ last-choice ] if
|
||||
] if ;
|
||||
|
||||
: resolve ( name pattern -- fact )
|
||||
2dup lookup-fact dup "No." = [ drop lookup-rule ] [ 2nip ] if ;
|
||||
|
||||
: binding-resolve ( binds name pattern -- binds )
|
||||
tuck lookup-fact dup backtrace? swap rot add-bindings ;
|
||||
|
||||
! { { "A" "a" } { "B" "b" } } { { { "C" } "A" "B" = [ { "c" } ] [ { "d" } ] if rot add-bindings } }
|
||||
Loading…
Reference in New Issue