From 4fb5084de9405093880a06e46f4c4d9d9092bded Mon Sep 17 00:00:00 2001 From: Gavin Harrison Date: Sat, 8 Dec 2007 02:13:39 -0500 Subject: [PATCH 1/5] new file: extra/prolog/authors.txt new file: extra/prolog/prolog.factor new file: extra/prolog/summary.txt new file: extra/prolog/tags.txt --- extra/prolog/authors.txt | 1 + extra/prolog/prolog.factor | 82 +++++++++++++++++++++++ extra/prolog/prolog.factor.1 | 91 ++++++++++++++++++++++++++ extra/prolog/prolog.factor.2 | 93 ++++++++++++++++++++++++++ extra/prolog/prolog.factor.3 | 122 +++++++++++++++++++++++++++++++++++ extra/prolog/summary.txt | 1 + extra/prolog/tags.txt | 1 + 7 files changed, 391 insertions(+) create mode 100644 extra/prolog/authors.txt create mode 100644 extra/prolog/prolog.factor create mode 100644 extra/prolog/prolog.factor.1 create mode 100644 extra/prolog/prolog.factor.2 create mode 100644 extra/prolog/prolog.factor.3 create mode 100644 extra/prolog/summary.txt create mode 100644 extra/prolog/tags.txt diff --git a/extra/prolog/authors.txt b/extra/prolog/authors.txt new file mode 100644 index 0000000000..194cb22416 --- /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 index 0000000000..2dba501449 --- /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 index 0000000000..93e3202355 --- /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 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 index 0000000000..dcd671bfe2 --- /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 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 index 0000000000..c97c547b20 --- /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 index 0000000000..48ad1f312e --- /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 index 0000000000..458345b533 --- /dev/null +++ b/extra/prolog/tags.txt @@ -0,0 +1 @@ +prolog From 053616dd6370699c3c3320adfa8f49e084a8377c Mon Sep 17 00:00:00 2001 From: Gavin Harrison Date: Sat, 8 Dec 2007 02:28:42 -0500 Subject: [PATCH 2/5] modified: extra/prolog/prolog.factor --- extra/prolog/prolog.factor | 2 + extra/prolog/prolog.factor.1 | 91 -------------------------- extra/prolog/prolog.factor.2 | 93 -------------------------- extra/prolog/prolog.factor.3 | 122 ----------------------------------- 4 files changed, 2 insertions(+), 306 deletions(-) delete mode 100644 extra/prolog/prolog.factor.1 delete mode 100644 extra/prolog/prolog.factor.2 delete mode 100644 extra/prolog/prolog.factor.3 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 } } From 3f4a2f59f66781989b1e0318c3b01858efb82a4a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Dec 2007 22:43:48 -0500 Subject: [PATCH 3/5] Fix annotations --- extra/webapps/pastebin/annotation.furnace | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/webapps/pastebin/annotation.furnace b/extra/webapps/pastebin/annotation.furnace index 420c1625f5..791905197e 100755 --- a/extra/webapps/pastebin/annotation.furnace +++ b/extra/webapps/pastebin/annotation.furnace @@ -1,11 +1,11 @@ -<% USING: namespaces io ; %> +<% USING: namespaces io furnace calendar ; %>

Annotation: <% "summary" get write %>

- +
Annotation by:<% "author" get write %>
Channel:<% "channel" get write %>
Created:<% "date" get write %>
Created:<% "date" get timestamp>string write %>
<% "syntax" render-template %> From a0d2d7b8de8069b50954745b18d8a259d196bd69 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Dec 2007 22:56:53 -0500 Subject: [PATCH 4/5] Pastebin fix --- extra/webapps/pastebin/paste-summary.furnace | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/webapps/pastebin/paste-summary.furnace b/extra/webapps/pastebin/paste-summary.furnace index f8938eabca..7e65e10a9e 100644 --- a/extra/webapps/pastebin/paste-summary.furnace +++ b/extra/webapps/pastebin/paste-summary.furnace @@ -4,7 +4,11 @@ furnace webapps.pastebin calendar ; %> - <% "summary" get write %> + <% + "summary" get + dup empty? [ drop "- no title -" ] when + write + %> <% "author" get write %> From 2719e51fa9d0d556ae4779e1178401282dc815fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Dec 2007 22:57:26 -0500 Subject: [PATCH 5/5] Pastebin fix --- extra/webapps/pastebin/paste-summary.furnace | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/pastebin/paste-summary.furnace b/extra/webapps/pastebin/paste-summary.furnace index 7e65e10a9e..2840110549 100644 --- a/extra/webapps/pastebin/paste-summary.furnace +++ b/extra/webapps/pastebin/paste-summary.furnace @@ -1,5 +1,5 @@ <% USING: continuations namespaces io kernel math math.parser -furnace webapps.pastebin calendar ; %> +furnace webapps.pastebin calendar sequences ; %>