diff --git a/extra/prolog/prolog.factor b/extra/prolog/prolog.factor index 2dba501449..0a6a513b97 100644 --- a/extra/prolog/prolog.factor +++ b/extra/prolog/prolog.factor @@ -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 ; diff --git a/extra/prolog/prolog.factor.1 b/extra/prolog/prolog.factor.1 deleted file mode 100644 index 93e3202355..0000000000 --- a/extra/prolog/prolog.factor.1 +++ /dev/null @@ -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 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 ) - diff --git a/extra/prolog/prolog.factor.2 b/extra/prolog/prolog.factor.2 deleted file mode 100644 index dcd671bfe2..0000000000 --- a/extra/prolog/prolog.factor.2 +++ /dev/null @@ -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 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 ; diff --git a/extra/prolog/prolog.factor.3 b/extra/prolog/prolog.factor.3 deleted file mode 100644 index c97c547b20..0000000000 --- a/extra/prolog/prolog.factor.3 +++ /dev/null @@ -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 } }