new file: extra/prolog/authors.txt

	new file:   extra/prolog/prolog.factor
	new file:   extra/prolog/summary.txt
	new file:   extra/prolog/tags.txt

diff --git a/extra/prolog/authors.txt b/extra/prolog/authors.txt
new file mode 100644 (file)
index 0000000..194cb22
--- /dev/null
+++ b/extra/prolog/authors.txt
@@ -0,0 +1 @@
+Gavin Harrison

diff --git a/extra/prolog/prolog.factor b/extra/prolog/prolog.factor
new file mode 100644 (file)
index 0000000..2dba501
--- /dev/null
+++ b/extra/prolog/prolog.factor
@@ -0,0 +1,82 @@
+
+USING: kernel sequences arrays vectors namespaces math strings
+    combinators continuations quotations io assocs ;
+
+IN: prolog
+
+SYMBOL: pldb
+SYMBOL: plchoice
+
+: init-pl ( -- ) V{ } clone pldb set V{ } clone plchoice set ;
+
+: reset-choice ( -- ) V{ } clone plchoice set ;
+: remove-choice ( -- ) plchoice get pop drop ;
+: add-choice ( continuation -- ) 
+    dup continuation? [ plchoice get push ] [ drop ] if ;
+: last-choice ( -- ) plchoice get pop continue ;
+
+: rules ( -- vector ) pldb get ;
+: 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-arity ( pat fact -- pattern fact ? ) 2dup [ length ] 2apply = ;
+: check-elements ( pat fact -- ? ) [ over var? [ 2drop t ] [ = ] if ] 2all? ;
+: (double-bound) ( key value assoc -- ? )
+    pick over at* [ pick = >r 3drop r> ] [ drop swapd set-at t ] if ;
+: single-bound? ( pat-d pat-f -- ? ) 
+    H{ } clone [ (double-bound) ] curry 2all? ;
+: match-pattern ( pat fact -- ? ) 
+    check-arity [ 2dup check-elements -rot single-bound? and ] [ 2drop f ] if ;
+: good-result? ( pat fact -- pat fact ? )
+    2dup dup "No." = [ 2drop t ] [ match-pattern ] if ;
+
+: add-rule ( name pat body -- ) 3array rules dup length swap set-nth ;
+
+: (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 pat -- fact )
+    swap 0 (lookup-rule) dup "No." =
+    [ nip ]
+    [ dup rule>pattern swapd check-arity 
+        [ rot rule>body resolve-rule dup -roll binds>fact nip ] [ last-choice ] if
+    ] if ;
+
+: binding-resolve ( binds name pat -- binds )
+    tuck lookup-rule dup backtrace? swap rot add-bindings ;
+
+: is ( binds val var -- binds ) rot [ set-at ] keep ;

diff --git a/extra/prolog/prolog.factor.1 b/extra/prolog/prolog.factor.1
new file mode 100644 (file)
index 0000000..93e3202
--- /dev/null
+++ b/extra/prolog/prolog.factor.1
@@ -0,0 +1,91 @@
+
+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 )
+    

diff --git a/extra/prolog/prolog.factor.2 b/extra/prolog/prolog.factor.2
new file mode 100644 (file)
index 0000000..dcd671b
--- /dev/null
+++ b/extra/prolog/prolog.factor.2
@@ -0,0 +1,93 @@
+
+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 ;

diff --git a/extra/prolog/prolog.factor.3 b/extra/prolog/prolog.factor.3
new file mode 100644 (file)
index 0000000..c97c547
--- /dev/null
+++ b/extra/prolog/prolog.factor.3
@@ -0,0 +1,122 @@
+
+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 } }

diff --git a/extra/prolog/summary.txt b/extra/prolog/summary.txt
new file mode 100644 (file)
index 0000000..48ad1f3
--- /dev/null
+++ b/extra/prolog/summary.txt
@@ -0,0 +1 @@
+Implementation of an embedded prolog for factor

diff --git a/extra/prolog/tags.txt b/extra/prolog/tags.txt
new file mode 100644 (file)
index 0000000..458345b
--- /dev/null
+++ b/extra/prolog/tags.txt
@@ -0,0 +1 @@
+prolog