+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test factlog factlog.examples.factorial ;
-IN: factlog.examples.factorial.tests
-
-{ { H{ { F 1 } } } } [ { factorial 0 F } query ] unit-test
-
-{ { H{ { F 1 } } } } [ { factorial 1 F } query ] unit-test
-
-{ { H{ { F 2 } } } } [ { factorial 2 F } query ] unit-test
-
-{ { H{ { F 3628800 } } } } [ { factorial 10 F } query ] unit-test
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: factlog kernel assocs math ;
-IN: factlog.examples.factorial
-
-LOGIC-PREDS: factorial ;
-LOGIC-VARS: N F N2 F2 ;
-
-{ factorial N F } {
- { (>) N 0 }
- [ [ N of 1 - ] N2 is ]
- { factorial N2 F2 }
- [ [ [ F2 of ] [ N of ] bi * ] F is ] !!
-} rule
-{ factorial 0 1 } fact
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test factlog lists factlog.examples.fib ;
-IN: factlog.examples.fib.tests
-
-{ { H{ { L L{ 0 } } } } } [ { fibo 0 L } query ] unit-test
-
-{ { H{ { L L{ 1 1 0 } } } } } [ { fibo 2 L } query ] unit-test
-
-{ { H{ { L L{ 55 34 21 13 8 5 3 2 1 1 0 } } } } } [
- { fibo 10 L } query
-] unit-test
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: factlog kernel lists assocs math ;
-IN: factlog.examples.fib
-
-LOGIC-PREDS: fibo ;
-LOGIC-VARS: F F1 F2 N N1 L ;
-
-{ fibo N L{ F F1 F2 . L } } {
- { (>) N 1 }
- [ [ N of 1 - ] N1 is ]
- { fibo N1 L{ F1 F2 . L } }
- [ [ [ F1 of ] [ F2 of ] bi + ] F is ] !!
-} rule
-
-{ fibo 0 L{ 0 } } !! rule
-
-{ fibo 1 L{ 1 0 } } fact
+++ /dev/null
-! Copyright (C) 2019 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test factlog factlog.examples.fib2 ;
-IN: factlog.examples.fib2.tests
-
-{ { H{ { F 6765 } } } } [
- { fibo 20 F } query
-] unit-test
+++ /dev/null
-! Copyright (C) 2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: factlog kernel lists assocs locals math ;
-IN: factlog.examples.fib2
-
-LOGIC-PREDS: fibo ;
-LOGIC-VARS: F F1 F2 N N1 N2 ;
-
-{ fibo 1 1 } fact
-{ fibo 2 1 } fact
-{ fibo N F } {
- { (>) N 2 }
- [ [ N of 1 - ] N1 is ] { fibo N1 F1 }
- [ [ N of 2 - ] N2 is ] { fibo N2 F2 }
- [ [ [ F1 of ] [ F2 of ] bi + ] F is ]
- [
- [
- [ N of ] [ F of ] bi
- [let :> ( nv fv ) { fibo nv fv } !! rule* ]
- ] invoke ]
-} rule
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test factlog factlog.examples.hanoi
-formatting sequences ;
-IN: factlog.examples.hanoi.tests
-
-{ t } [
- {
- "The following statements will be printed:"
- "move disk from left to center"
- "move disk from left to right"
- "move disk from center to right"
- "move disk from left to center"
- "move disk from right to left"
- "move disk from right to center"
- "move disk from left to center"
- " "
- } [ "%s\n" printf ] each
- { hanoi 3 } query
-] unit-test
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: factlog kernel assocs math ;
-IN: factlog.examples.hanoi
-
-LOGIC-PREDS: hanoi moveo informo ;
-LOGIC-VARS: A B C M N X Y ;
-SYMBOLS: left center right ;
-
-{ hanoi N } { moveo N left center right } rule
-
-{ moveo 0 __ __ __ } !! rule
-
-{ moveo N A B C } {
- [ [ N of 1 - ] M is ]
- { moveo M A C B }
- { informo A B }
- { moveo M C B A }
-} rule
-
-{ informo X Y } {
- { writeo { "move disk from " X " to " Y } } { nlo }
-} rule
-
-
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test factlog lists factlog.examples.hanoi2
-formatting sequences ;
-IN: factlog.examples.hanoi2.tests
-
-{ t } [
- {
- "The following statements will be printed:"
- "move Top from Left to Center"
- "move 2nd from Left to Right"
- "move Top from Center to Right"
- "move Base from Left to Center"
- "move Top from Right to Left"
- "move 2nd from Right to Center"
- "move Top from Left to Center"
- " "
- } [ "%s\n" printf ] each
- { hanoi L{ "Base" "2nd" "Top" } "Left" "Center" "Right" } query
-] unit-test
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: factlog lists sequences assocs formatting ;
-IN: factlog.examples.hanoi2
-
-LOGIC-PREDS: hanoi write-move ;
-LOGIC-VARS: A B C X Y Z ;
-
-{ write-move X } [ X of [ printf ] each t ] callback
-
-{ hanoi L{ } A B C } fact
-
-{ hanoi L{ X . Y } A B C } {
- { hanoi Y A C B }
- { write-move { "move " X " from " A " to " B "\n" } }
- { hanoi Y C B A }
-} rule
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test factlog lists factlog.examples.money ;
-IN: factlog.examples.money.tests
-
-{
- {
- H{
- { N1 L{ 0 9 5 6 7 } }
- { N2 L{ 0 1 0 8 5 } }
- { N L{ 1 0 6 5 2 } }
- }
- }
-}
-[
- { { moneyo N1 N2 N } { sumo N1 N2 N } } query
- S-and-M-can't-be-zero
-] unit-test
-
-{
- {
- H{
- { N1 L{ 5 2 6 4 8 5 } }
- { N2 L{ 1 9 7 4 8 5 } }
- { N L{ 7 2 3 9 7 0 } }
- }
- }
-}
-[
- { { donaldo N1 N2 N } { sumo N1 N2 N } } query
-] unit-test
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: factlog lists assocs sequences kernel math
-locals formatting io ;
-IN: factlog.examples.money
-
-LOGIC-PREDS: sumo sum1o digitsumo delo donaldo moneyo ;
-LOGIC-VARS: S E N D M O R Y A L G B T
- N1 N2 C C1 C2 D1 D2 L1
- Digits Digs Digs1 Digs2 Digs3 ;
-
-{ sumo N1 N2 N } {
- { sum1o N1 N2 N 0 0 L{ 0 1 2 3 4 5 6 7 8 9 } __ }
-} rule
-
-{ sum1o L{ } L{ } L{ } 0 0 Digits Digits } fact
-{ sum1o L{ D1 . N1 } L{ D2 . N2 } L{ D . N } C1 C Digs1 Digs } {
- { sum1o N1 N2 N C1 C2 Digs1 Digs2 }
- { digitsumo D1 D2 C2 D C Digs2 Digs }
-} rule
-
-{ digitsumo D1 D2 C1 D C Digs1 Digs } {
- { delo D1 Digs1 Digs2 }
- { delo D2 Digs2 Digs3 }
- { delo D Digs3 Digs }
- [ [ [ D1 of ] [ D2 of ] [ C1 of ] tri + + ] S is ]
- [ [ S of 10 mod ] D is ]
- [ [ S of 10 / >integer ] C is ]
-} rule
-
-{ delo A L L } { { nonvaro A } !! } rule
-{ delo A L{ A . L } L } fact
-{ delo A L{ B . L } L{ B . L1 } } { delo A L L1 } rule
-
-{ moneyo
- L{ 0 S E N D }
- L{ 0 M O R E }
- L{ M O N E Y }
-} fact
-
-{ donaldo
- L{ D O N A L D }
- L{ G E R A L D }
- L{ R O B E R T }
-} fact
-
-:: S-and-M-can't-be-zero ( seq -- seq' )
- seq [| hash |
- 1 hash N1 of list>array nth 0 = not
- 1 hash N2 of list>array nth 0 = not and
- ] filter ;
-
-:: print-puzzle ( hash-array -- )
- hash-array
- [| hash |
- " " printf hash N1 of list>array [ "%d " printf ] each nl
- "+ " printf hash N2 of list>array [ "%d " printf ] each nl
- "----------------" printf nl
- " " printf hash N of list>array [ "%d " printf ] each nl nl
- ] each ;
+++ /dev/null
-! Copyright (C) 2019 Your name.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test factlog factlog.examples.zebra-short ;
-IN: factlog.examples.zebra-short.tests
-
-{
- { H{ { X japanese } } H{ { X japanese } } }
-}
-[ { zebrao X } query ] unit-test
-
+++ /dev/null
-! Copyright (C) 2019 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: factlog arrays ;
-IN: factlog.examples.zebra-short
-
-! Do the same as this Prolog program
-!
-! neighbor(L,R,[L,R|_]).
-! neighbor(L,R,[_|Xs]) :- neighbor(L,R,Xs).
-!
-! zebra(X) :- Street = [H1,H2,H3],
-! member(house(red,english,_), Street),
-! member(house(_,spanish,dog), Street),
-! neighbor(house(_,_,cat), house(_,japanese,_), Street),
-! neighbor(house(_,_,cat), house(blue,_,_), Street),
-! member(house(_,X,zebra),Street).
-
-LOGIC-PREDS: neighboro zebrao ;
-LOGIC-VARS: L R X Xs H1 H2 H3 Street ;
-SYMBOLS: red blue ;
-SYMBOLS: english spanish japanese ;
-SYMBOLS: dog cat zebra ;
-TUPLE: house color nationality pet ;
-
-{ neighboro L R L{ L R . __ } } fact
-{ neighboro L R L{ __ . Xs } } { neighboro L R Xs } rule
-
-{ zebrao X } {
- { (=) Street L{ H1 H2 H3 } }
- { membero [ T{ house f red english __ } ] Street }
- { membero [ T{ house f __ spanish dog } ] Street }
- { neighboro [ T{ house f __ __ cat } ] [ T{ house f __ japanese __ } ] Street }
- { neighboro [ T{ house f __ __ cat } ] [ T{ house f blue __ __ } ] Street }
- { membero [ T{ house f __ X zebra } ] Street }
-} rule
-
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test factlog lists factlog.examples.zebra ;
-IN: factlog.examples.zebra.tests
-
-{
- {
- H{
- {
- Hs
- L{
- T{ house
- { color yellow }
- { nationality norwegian }
- { drink water }
- { smoke dunhill }
- { pet cat }
- }
- T{ house
- { color blue }
- { nationality dane }
- { drink tea }
- { smoke blend }
- { pet horse }
- }
- T{ house
- { color red }
- { nationality english }
- { drink milk }
- { smoke pall-mall }
- { pet birds }
- }
- T{ house
- { color green }
- { nationality german }
- { drink coffee }
- { smoke prince }
- { pet zebra }
- }
- T{ house
- { color white }
- { nationality swede }
- { drink beer }
- { smoke blue-master }
- { pet dog }
- }
- }
- }
- { X norwegian }
- { Y german }
- }
- }
-}
-[ { houseso Hs X Y } query ] unit-test
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-
-! Zebra Puzzle: https://rosettacode.org/wiki/Zebra_puzzle
-
-USING: factlog lists ;
-IN: factlog.examples.zebra
-
-LOGIC-PREDS: houseso neighboro zebrao watero nexto lefto ;
-LOGIC-VARS: Hs A B Ls X Y ;
-SYMBOLS: red blue green white yellow ;
-SYMBOLS: english swede dane norwegian german ;
-SYMBOLS: dog cat birds horse zebra ;
-SYMBOLS: tea coffee beer milk water ;
-SYMBOLS: pall-mall dunhill blue-master prince blend ;
-TUPLE: house color nationality drink smoke pet ;
-
-{ houseso Hs X Y } {
- { (=) Hs ! #1
- L{ T{ house f __ norwegian __ __ __ } ! #10
- T{ house f blue __ __ __ __ } ! #15
- T{ house f __ __ milk __ __ } ! #9
- __
- __ } }
- { membero T{ house f red english __ __ __ } Hs } ! #2
- { membero T{ house f __ swede __ __ dog } Hs } ! #3
- { membero T{ house f __ dane tea __ __ } Hs } ! #4
- { lefto T{ house f green __ __ __ __ } T{ house f white __ __ __ __ } Hs } ! #5
- { membero T{ house f green __ coffee __ __ } Hs } ! #6
- { membero T{ house f __ __ __ pall-mall birds } Hs } ! #7
- { membero T{ house f yellow __ __ dunhill __ } Hs } ! #8
- { nexto T{ house f __ __ __ blend __ } T{ house f __ __ __ __ cat } Hs } ! #11
- { nexto T{ house f __ __ __ dunhill __ } T{ house f __ __ __ __ horse } Hs } ! #12
- { membero T{ house f __ __ beer blue-master __ } Hs } ! #13
- { membero T{ house f __ german __ prince __ } Hs } ! #14
- { nexto T{ house f __ __ water __ __ } T{ house f __ __ __ blend __ } Hs } ! #16
- { membero T{ house f __ X water __ __ } Hs }
- { membero T{ house f __ Y __ __ zebra } Hs }
-} rule
-
-{ nexto A B Ls } {
- { appendo __ L{ A B . __ } Ls } ;;
- { appendo __ L{ B A . __ } Ls }
-} rule
-
-{ lefto A B Ls } { appendo __ L{ A B . __ } Ls } rule
-
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test factlog lists factlog.examples.zebra2 ;
-IN: factlog.examples.zebra2.tests
-
-{
- {
- H{
- {
- Hs
- L{
- T{ house
- { color yellow }
- { nationality norwegian }
- { drink water }
- { smoke dunhill }
- { pet cat }
- }
- T{ house
- { color blue }
- { nationality dane }
- { drink tea }
- { smoke blend }
- { pet horse }
- }
- T{ house
- { color red }
- { nationality english }
- { drink milk }
- { smoke pall-mall }
- { pet birds }
- }
- T{ house
- { color green }
- { nationality german }
- { drink coffee }
- { smoke prince }
- { pet zebra }
- }
- T{ house
- { color white }
- { nationality swede }
- { drink beer }
- { smoke blue-master }
- { pet dog }
- }
- }
- }
- { X norwegian }
- { Y german }
- }
- }
-}
-[ { houseso Hs X Y } query ] unit-test
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: factlog lists ;
-IN: factlog.examples.zebra2
-
-LOGIC-PREDS: existso righto middleo firsto nexto
- houseso zebrao watero ;
-LOGIC-VARS: A B L R Hs X Y ;
-SYMBOLS: red blue green white yellow ;
-SYMBOLS: english swede dane german norwegian ;
-SYMBOLS: dog birds zebra cat horse ;
-SYMBOLS: coffee tea milk beer water ;
-SYMBOLS: prince dunhill pall-mall blend blue-master ;
-
-TUPLE: house color nationality drink smoke pet ;
-{
- { existso A L{ A __ __ __ __ } }
- { existso A L{ __ A __ __ __ } }
- { existso A L{ __ __ A __ __ } }
- { existso A L{ __ __ __ A __ } }
- { existso A L{ __ __ __ __ A } }
-
- { righto R L L{ L R __ __ __ } }
- { righto R L L{ __ L R __ __ } }
- { righto R L L{ __ __ L R __ } }
- { righto R L L{ __ __ __ L R } }
-
- { middleo A L{ __ __ A __ __ } }
-
- { firsto A L{ A __ __ __ __ } }
-
- { nexto A B L{ B A __ __ __ } }
- { nexto A B L{ __ B A __ __ } }
- { nexto A B L{ __ __ B A __ } }
- { nexto A B L{ __ __ __ B A } }
- { nexto A B L{ A B __ __ __ } }
- { nexto A B L{ __ A B __ __ } }
- { nexto A B L{ __ __ A B __ } }
- { nexto A B L{ __ __ __ A B } }
-} facts
-
-{ houseso Hs X Y } {
- { existso T{ house f red english __ __ __ } Hs } ! #2
- { existso T{ house f __ swede __ __ dog } Hs } ! #3
- { existso T{ house f __ dane tea __ __ } Hs } ! #4
- { righto T{ house f white __ __ __ __ } T{ house f green __ __ __ __ } Hs } ! #5
- { existso T{ house f green __ coffee __ __ } Hs } ! #6
- { existso T{ house f __ __ __ pall-mall birds } Hs } ! #7
- { existso T{ house f yellow __ __ dunhill __ } Hs } ! #8
- { middleo T{ house f __ __ milk __ __ } Hs } ! #9
- { firsto T{ house f __ norwegian __ __ __ } Hs } ! #10
- { nexto T{ house f __ __ __ blend __ } T{ house f __ __ __ __ cat } Hs } ! #11
- { nexto T{ house f __ __ __ dunhill __ } T{ house f __ __ __ __ horse } Hs } ! #12
- { existso T{ house f __ __ beer blue-master __ } Hs } ! #13
- { existso T{ house f __ german __ prince __ } Hs } ! #14
- { nexto T{ house f __ norwegian __ __ __ } T{ house f blue __ __ __ __ } Hs } ! #15
- { nexto T{ house f __ __ water __ __ } T{ house f __ __ __ blend __ } Hs } ! #16
- { existso T{ house f __ X water __ __ } Hs }
- { existso T{ house f __ Y __ __ zebra } Hs }
-} rule
-
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.markup help.syntax kernel quotations sequences
- prettyprint assocs math make lists urls factlog.private ;
-IN: factlog
-
-HELP: !!
-{ $var-description "The cut operator.\nUse the cut operator to suppress backtracking." }
-{ $examples
- "In the following example, it is used to define that cats generally eat mice, but Tom does not."
- { $example
- "USING: factlog prettyprint ;"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: is-ao consumeso ;"
- "LOGIC-VARS: X Y ;"
- "SYMBOLS: Tom Jerry Nibbles"
- " mouse cat milk cheese fresh-milk Emmentaler ;"
- ""
- "{"
- " { is-ao Tom cat }"
- " { is-ao Jerry mouse }"
- " { is-ao Nibbles mouse }"
- " { is-ao fresh-milk milk }"
- " { is-ao Emmentaler cheese }"
- "} facts"
- ""
- "{ consumeso X milk } {"
- " { is-ao X mouse } ;;"
- " { is-ao X cat }"
- "} rule"
- ""
- "{ consumeso X cheese } { is-ao X mouse } rule"
- "{ consumeso Tom mouse } { !! f } rule"
- "{ consumeso X mouse } { is-ao X cat } rule"
- ""
- "{ { consumeso Tom X } { is-ao Y X } } query ."
- "{ H{ { X milk } { Y fresh-milk } } }"
- }
-} ;
-
-HELP: (<)
-{ $var-description "A logic predicate. It takes two arguments. It is true if both arguments are evaluated numerically and the first argument is less than the second, otherwise, it is false." }
-{ $syntax "{ (<) X Y }" }
-{ $see-also (>) (>=) (==) (=<) } ;
-
-HELP: (=)
-{ $var-description "A logic predicate. It unifies two arguments." }
-{ $syntax "{ (=) X Y }" }
-{ $see-also (\=) is } ;
-
-HELP: (=<)
-{ $var-description "A logic predicate. It takes two arguments. It is true if both arguments are evaluated numerically and the first argument equals or is less than the second, otherwise, it is false." }
-{ $syntax "{ (=<) X Y }" }
-{ $see-also (>) (>=) (==) (<) } ;
-
-HELP: (==)
-{ $var-description "A logic predicate. It tests for equality of two arguments. Evaluating two arguments, true if they are the same, false if they are different." }
-{ $syntax "{ (==) X Y }" }
-{ $see-also (>) (>=) (=<) (<) =:= =\= } ;
-
-HELP: (>)
-{ $var-description "A logic predicate. It is true if both arguments are evaluated numerically and the first argument is greater than the second, otherwise, it is false." }
-{ $syntax "{ (>) X Y }" }
-{ $see-also (>=) (==) (=<) (<) } ;
-
-HELP: (>=)
-{ $var-description "A logic predicate. It is true if both arguments are evaluated numerically and the first argument equals or is greater than the second, otherwise, it is false." }
-{ $syntax "{ (>=) X Y }" }
-{ $see-also (>) (==) (=<) (<) } ;
-
-HELP: (\=)
-{ $var-description "A logic predicate. It will be true when such a unification fails. Note that " { $snippet "(\\=)" } " does not actually do the unification." }
-{ $syntax "{ (\\=) X Y }" }
-{ $see-also (=) } ;
-
-HELP: (\==)
-{ $var-description "A logic predicate. It tests for inequality of two arguments. Evaluating two arguments, true if they are different, false if they are the same." }
-{ $syntax "{ (\\==) X Y }" }
-;
-
-HELP: ;;
-{ $var-description "Is used to represent disjunction. The code below it has the same meaning as the code below it.
-"
-{ $code
- "Gh { Gb1 Gb2 Gb3 ;; Gb4 Gb5 ;; Gb6 } rule" }
-""
-{ $code
- "Gh { Gb1 Gb2 Gb3 } rule"
- "Gh { Gb4 Gb5 } rule:
-Gh { Gb6 } rule" }
-} ;
-
-HELP: =:=
-{ $values
- { "quot" quotation }
- { "goal" logic-goal }
-}
-{ $description "The quotations takes an environment and returns two values. " { $snippet "=:=" } " returns the internal representation of the goal which returns t if values returned by the quotation are same numbers.\n" { $snippet "=:=" } " is intended to be used in a quotation. If there is a quotation in the definition of rule, factlog uses the internal definition of the goal obtained by calling it." }
-{ $see-also (==) =\= } ;
-
-HELP: =\=
-{ $values
- { "quot" quotation }
- { "goal" logic-goal }
-}
-{ $description "The quotations takes an environment and returns two values. " { $snippet "=\\=" } " returns the internal representation of the goal which returns t if values returned by the quotation are numbers and are not same.\n" { $snippet "=\\=" } " is intended to be used in a quotation. If there is a quotation in the definition of rule, factlog uses the internal definition of the goal obtained by calling it." }
-{ $see-also (==) =:= } ;
-
-HELP: LOGIC-PREDS:
-{ $description "Creates a new logic predicate for every token until the ;." }
-{ $syntax "LOGIC-PREDS: preds... ;" }
-{ $examples
- { $code
- "USE: factlog"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: cato mouseo ;"
- "SYMBOLS: Tom Jerry ;"
- ""
- "{ cato Tom } fact"
- "{ mouseo Jerry } fact"
- }
-} ;
-
-HELP: LOGIC-VARS:
-{ $description "Creates a new logic variable for every token until the ;." }
-{ $syntax "LOGIC-VARS: vars... ;" }
-{ $examples
- { $example
- "USING: factlog prettyprint ;"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: mouseo ;"
- "LOGIC-VARS: X ;"
- "SYMBOL: Jerry"
- "{ mouseo Jerry } fact"
- "{ mouseo X } query ."
- "{ H{ { X Jerry } } }"
- }
-} ;
-
-HELP: %!
-{ $description "A multiline comment. Despite being a Prolog single-line comment, " { $link % } " is already well-known in Factor, so this variant is given instead." }
-{ $syntax "%! comment !%" }
-{ $examples
- { $example
- "USE: factlog"
- "%! I think that I shall never see"
- " A proof lovely as a factlog. !%"
- ""
- }
-} ;
-
-HELP: \+
-{ $var-description "Express negation. \\+ acts on the goal immediately following it.\n" }
-{ $examples
- { $example
- "USING: factlog prettyprint ;"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: cato mouseo creatureo ;"
- "LOGIC-VARS: X Y ;"
- "SYMBOLS: Tom Jerry Nibbles ;"
- ""
- "{ cato Tom } fact"
- "{ mouseo Jerry } fact"
- "{ mouseo Nibbles } fact"
- "{ creatureo Y } {
- { cato Y } ;; { mouseo Y }
-} rule"
- ""
- "LOGIC-PREDS: likes-cheeseo dislikes-cheeseo ;"
- ""
- "{ likes-cheeseo X } { mouseo X } rule"
- "{ dislikes-cheeseo Y } {
- { creatureo Y }
- \\+ { likes-cheeseo Y }
- } rule"
- "{ dislikes-cheeseo Jerry } query ."
- "{ dislikes-cheeseo Tom } query ."
- "f\nt"
- }
-} ;
-
-HELP: __
-{ $var-description "An anonymous logic variable.\nUse in place of a regular logic variable when you do not need its name and value." }
-{ $examples
- { $example
- "USING: factlog prettyprint ;"
- "IN: scratchpad"
- ""
- "SYMBOLS: Tom Jerry Nibbles ;"
- "TUPLE: house living dining kitchen in-the-wall ;"
- "LOGIC-PREDS: houseo ;"
- "LOGIC-VARS: X ;"
-
- ""
- "{ houseo T{ house"
- " { living Tom }"
- " { dining f }"
- " { kitchen Nibbles }"
- " { in-the-wall Jerry }"
- " }"
- "} fact"
- ""
- "{ houseo T{ house"
- " { living __ }"
- " { dining __ }"
- " { kitchen X }"
- " { in-the-wall __ }"
- " }"
- "} query ."
- "{ H{ { X Nibbles } } }"
- }
-} ;
-
-HELP: appendo
-{ $var-description "A logic predicate. Concatenate two lists." }
-{ $syntax "{ appendo List1 List2 List1+List2 }" }
-{ $examples
- { $example
- "USING: factlog lists prettyprint ;"
- "IN: scratchpad"
- ""
- "SYMBOLS: Tom Jerry Nibbles ;"
- "LOGIC-VARS: X Y ;"
- ""
- "{ appendo L{ Tom } L{ Jerry Nibbles } X } query ."
- "{ appendo L{ Tom } L{ Jerry Nibbles } L{ Jerry Nibbles Tom } } query ."
- "{ appendo X Y L{ Tom Jerry Nibbles } } query ."
- "{ H{ { X L{ Tom Jerry Nibbles } } } }\nf\n{\n H{ { X L{ } } { Y L{ Tom Jerry Nibbles } } }\n H{ { X L{ Tom } } { Y L{ Jerry Nibbles } } }\n H{ { X L{ Tom Jerry } } { Y L{ Nibbles } } }\n H{ { X L{ Tom Jerry Nibbles } } { Y L{ } } }\n}"
- }
-} ;
-
-HELP: callback
-{ $values
- { "head" array } { "quot" quotation }
-}
-{ $description "Set the quotation to be called. Such quotations take an environment which holds the binding of logic variables, and returns t or " { $link f } " as a result of execution. To retrieve the values of logic variables in the environment, use " { $link of } " or " { $link at } "." }
-{ $examples
- { $code
- "LOGIC-PREDS: N_>_0 ;"
- "{ N_>_0 N } [ N of 0 > ] callback"
- }
-}
-{ $see-also callbacks } ;
-
-HELP: callbacks
-{ $values
- { "defs" array }
-}
-{ $description "To collectively register a plurality of " { $link callback } "s." }
-{ $examples
- { $code "LOGIC-PREDS: N_>_0 N2_is_N_-_1 F_is_F2_*_N ;
-{
- { { N_>_0 N } [ N of 0 > ] }
- { N2_is_N_-_1 N2 N } [ dup N of 1 - N2 unify ] }
- { F_is_F2_*_N F F2 N } [ dup [ F2 of ] [ N of ] bi * F unify ] }
-} callbacks" }
-}
-{ $see-also callback } ;
-
-HELP: clear-pred
-{ $values
- { "pred" "a logic predicate" }
-}
-{ $description "Clears all the definition information for the given logic predicate." }
-{ $examples
- { $example
- "USING: factlog prettyprint ;"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: mouseo ;"
- "SYMBOLS: Jerry Nibbles ;"
- "LOGIC-VARS: X ;"
- ""
- "{ mouseo Jerry } fact"
- "{ mouseo Nibbles } fact"
- ""
- "{ mouseo X } query ."
- "mouseo clear-pred"
- "{ mouseo X } query ."
- "{ H{ { X Jerry } } H{ { X Nibbles } } }\nf"
- }
-}
-{ $see-also retract retract-all } ;
-
-HELP: fact
-{ $values
- { "head" "an array representing a goal" }
-}
-{ $description "Registers the fact to the end of the logic predicate that is in the head." }
-{ $examples
- { $code
- "USE: factlog"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: cato mouseo ;"
- "SYMBOLS: Tom Jerry ;"
- "{ cato Tom } fact"
- "{ mouseo Jerry } fact"
- }
-}
-{ $see-also fact* facts } ;
-
-HELP: fact*
-{ $values
- { "head" "an array representing a goal" }
-}
-{ $description "Registers the fact to the beginning of the logic predicate that is in the head." }
-{ $see-also fact facts } ;
-
-HELP: facts
-{ $values
- { "defs" array }
-}
-{ $description "Registers these facts to the end of the logic predicate that is in the head." }
-{ $examples
- { $code
- "USE: factlog"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: cato mouseo ;"
- ""
- "{ { cato Tom } { mouseo Jerry } } facts"
- }
-}
-{ $see-also fact fact* } ;
-
-HELP: failo
-{ $var-description "A built-in logic predicate. { " { $snippet "failo" } " } is a goal that is always " { $link f } "." }
-{ $syntax "{ failo }" }
-{ $see-also trueo } ;
-
-HELP: is
-{ $values
- { "quot" quotation } { "dist" "a logic predicate" }
- { "goal" logic-goal }
-}
-{ $description "Takes a quotation and a logic variable to be unified. Each of the two quotations takes an environment and returns a value. " { $snippet "is" } " returns the internal representation of the goal.\n" { $snippet "is" } " is intended to be used in a quotation. If there is a quotation in the definition of rule, factlog uses the internal definition of the goal obtained by calling it." } ;
-
-HELP: invoke
-{ $values
- { "quot" quotation }
- { "goal" logic-goal }
-}
-{ $description "Creates a goal which uses the values of obtained logic variables. It can be used to add new rules to or drop rules from the database while a " { $link query } " is running.\nThe argument " { $snippet "quot" } " must not return any values, the created goal always return " { $link t } ".\n" { $snippet "invoke" } " is intended to be used in a quotation. If there is a quotation in the definition of rule, factlog uses the internal definition of the goal obtained by calling it." }
-{ $examples
- "In this example, the calculated values are memorized to eliminate recalculation."
- { $example
- "USING: factlog kernel lists assocs locals math prettyprint ;"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: fibo ;"
- "LOGIC-VARS: F F1 F2 N N1 N2 ;"
- ""
- "{ fibo 1 1 } fact"
- "{ fibo 2 1 } fact"
- "{ fibo N F } {"
- " { (>) N 2 }"
- " [ [ N of 1 - ] N1 is ] { fibo N1 F1 }"
- " [ [ N of 2 - ] N2 is ] { fibo N2 F2 }"
- " [ [ [ F1 of ] [ F2 of ] bi + ] F is ]"
- " ["
- " ["
- " [ N of ] [ F of ] bi"
- " [let :> ( nv fv ) { fibo nv fv } !! rule* ]"
- " ] invoke ]"
- "} rule"
- ""
- "{ fibo 10 F } query ."
- "{ H{ { F 55 } } }"
- }
-}
-{ $see-also invoke* } ;
-
-HELP: invoke*
-{ $values
- { "quot" quotation }
- { "goal" logic-goal }
-}
-{ $description "Creates a goal which uses the values of obtained logic variables. The difference with " { $link invoke } " is that " { $snippet "quot" } " returns " { $link t } " or " { $link f } ", and the created goal returns it.\n" { $snippet "invoke*" } " is intended to be used in a quotation. If there is a quotation in the definition of rule, factlog uses the internal definition of the goal obtained by calling it." }
-{ $see-also invoke } ;
-
-HELP: lengtho
-{ $var-description "A logic predicate. Instantiate the length of the list." }
-{ $syntax "{ lengtho List X }" }
-{ $examples
- { $example
- "USING: factlog lists prettyprint ;"
- "IN: scratchpad"
- ""
- "SYMBOLS: Tom Jerry Nibbles ;"
- "LOGIC-VARS: X ;"
- ""
- "{ lengtho L{ Tom Jerry Nibbles } 3 } query ."
- "{ lengtho L{ Tom Jerry Nibbles } X } query ."
- "t\n{ H{ { X 3 } } }"
- }
-} ;
-
-HELP: listo
-{ $var-description "A logic predicate. Takes a single argument and checks to see if it is a list." }
-{ $syntax "{ listo X }" }
-{ $examples
- { $example
- "USING: factlog lists prettyprint ;"
- "IN: scratchpad"
- ""
- "SYMBOLS: Tom Jerry Nibbles ;"
- ""
- "{ listo L{ Jerry Nibbles } } query ."
- "{ listo Tom } query ."
- "t\nf"
- }
-} ;
-
-HELP: membero
-{ $var-description "A logic predicate for the relationship an element is in a list." }
-{ $syntax "{ membero X List }" }
-{ $examples
- { $example
- "USING: factlog lists prettyprint ;"
- "IN: scratchpad"
- ""
- "SYMBOLS: Tom Jerry Nibbles Spike ;"
- ""
- "{ membero Jerry L{ Tom Jerry Nibbles } } query ."
- "{ membero Spike L{ Tom Jerry Nibbles } } query ."
- "t\nf"
- }
-} ;
-
-HELP: nlo
-{ $var-description "A logic predicate. Print line breaks." }
-{ $syntax "{ nlo }" }
-{ $see-also writeo writenlo } ;
-
-HELP: nonvaro
-{ $var-description "A logic predicate. "{ $snippet "nonvaro" } " takes a single argument and is true if its argument is not a logic variable or is a concrete logic variable." }
-{ $syntax "{ nonvaro X }" }
-{ $see-also varo } ;
-
-HELP: notrace
-{ $description "Stop tracing." }
-{ $see-also trace } ;
-
-HELP: query
-{ $values
- { "goal-def/defs" "a goal def or an array of goal defs" }
- { "bindings-array/success?" "anser" }
-}
-{ $description
- "Inquire about the order of goals. The general form of a query is:
-
- { G1 G2 ... Gn } query
-
-This G1, G2, ... Gn is a conjunction. When all of them are satisfied, it becomes " { $link t } ".
-
-If there is only one goal, you can use its abbreviation.
-
- G1 query
-
-When you query with logic variable(s), you will get the answer for the logic variable(s). For such queries, an array of hashtables with logic variables as keys is returned.
-"
-}
-{ $examples
- { $example
- "USING: factlog prettyprint ;"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: cato mouseo creatureo ;"
- "LOGIC-VARS: X Y ;"
- "SYMBOLS: Tom Jerry Nibbles ;"
- ""
- "{ cato Tom } fact"
- "{ mouseo Jerry } fact"
- "{ mouseo Nibbles } fact"
- ""
- "{ cato Tom } query ."
- "{ { cato Tom } { cato Jerry } } query ."
- "{ mouseo X } query ."
- "t\nf\n{ H{ { X Jerry } } H{ { X Nibbles } } }"
- }
-}
-{ $see-also query-n } ;
-
-HELP: query-n
-{ $values
- { "goal-def/defs" "a goal def or an array of goal defs" } { "n/f" "the highest number of responses" }
- { "bindings-array/success?" "anser" }
-}
-{ $description "The version of " { $link query } " that limits the number of responses. Specify a number greater than or equal to 1.
-If " { $link f } " is given instead of a number as " { $snippet "n/f" } ", there is no limit to the number of answers. That is, the behavior is the same as " { $link query } "." }
-{ $see-also query } ;
-
-HELP: retract
-{ $values
- { "head-def" "a logic predicate" }
-}
-{ $description "Removes the first definition that matches the given head information." }
-{ $examples
- { $example
- "USING: factlog prettyprint ;"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: mouseo ;"
- "SYMBOLS: Jerry Nibbles ;"
- ""
- "{ mouseo Jerry } fact"
- "{ mouseo Nibbles } fact"
- ""
- "{ mouseo X } query ."
- "{ mouseo Jerry } retract"
- "{ mouseo X } query ."
- "{ H{ { X Jerry } } H{ { X Nibbles } } }\n{ H{ { X Nibbles } } }"
- }
-}
-{ $see-also retract-all clear-pred } ;
-
-HELP: retract-all
-{ $values
- { "head-def" "a logic predicate" }
-}
-{ $description "Removes all definitions that match a given head goal definition." }
-{ $examples
- { $example
- "USING: factlog prettyprint ;"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: mouseo ;"
- "SYMBOLS: Jerry Nibbles ;"
- ""
- "{ mouseo Jerry } fact"
- "{ mouseo Nibbles } fact"
- ""
- "{ mouseo X } query ."
- "{ mouseo __ } retract-all"
- "{ mouseo X } query ."
- "{ H{ { X Jerry } } H{ { X Nibbles } } }\nf"
- }
-}
-{ $see-also retract clear-pred } ;
-
-HELP: rule
-{ $values
- { "head" "an array representing a goal" } { "body" "an array of goals or a goal" }
-}
-{ $description "Registers the rule to the end of the logic predicate that is in the head.
-The general form of rule is:
-
- Gh { Gb1 Gb2 ... Gbn } rule
-
-This means Gh when all goals of Gb1, Gb2, ..., Gbn are met. This Gb1 Gb2 ... Gbn is a conjunction.
-If the body array contains only one goal definition, you can write it instead of the body array. That is, they are equivalent.
-
- Gh { Gb } rule
- Gh Gb rule" }
-{ $examples
- { $example
- "USING: factlog prettyprint ;"
- "IN: scratchpad"
- ""
- "LOGIC-PREDS: mouseo youngo young-mouseo ;"
- "SYMBOLS: Jerry Nibbles ;"
- ""
- "{ mouseo Jerry } fact"
- "{ mouseo Nibbles } fact"
- "{ youngo Nibbles } fact"
- ""
- "{ young-mouseo X } {"
- " { mouseo X }"
- " { youngo X }"
- "} rule"
- ""
- "{ young-mouseo X } query ."
- "{ H{ { X Nibbles } } }"
- }
-}
-{ $see-also rule* rules } ;
-
-HELP: rule*
-{ $values
- { "head" "an array representing a goal" } { "body" "an array of goals or a goal" }
-}
-{ $description "Registers the rule to the beginnung of the logic predicate that is in the head." }
-{ $see-also rule rules } ;
-
-HELP: rules
-{ $values
- { "defs" "an array of rules" }
-}
-{ $description "Registers these rules to the end of the logic predicate that is in these heads." }
-{ $examples
- { $code
- "LOGIC-PREDS: is-ao consumeso ;"
- "SYMBOLS: Tom Jerry Nibbles ;"
- "SYMBOLS: mouse cat milk cheese fresh-milk Emmentaler ;"
- ""
- "{"
- " { is-ao Tom cat }"
- " { is-ao Jerry mouse }"
- " { is-ao Nibbles mouse }"
- " { is-ao fresh-milk milk }"
- " { is-ao Emmentaler cheese }"
- "} facts"
- ""
- "{"
- " {"
- " { consumeso X milk } {"
- " { is-ao X mouse } ;;"
- " { is-ao X cat }"
- " }"
- " }"
- " { { consumeso X cheese } { is-ao X mouse } }"
- " { { consumeso X mouse } { is-ao X cat } }"
- "} rules"
- }
-}
-{ $see-also rule rule* } ;
-
-HELP: trace
-{ $description "Start tracing." }
-{ $see-also notrace } ;
-
-HELP: trueo
-{ $var-description "A logic predicate. { " { $snippet "trueo" } " } is a goal that is always " { $link t } "." }
-{ $syntax "{ trueo }" }
-{ $see-also failo } ;
-
-HELP: unify
-{ $values
- { "cb-env" callback-env } { "x" object } { "y" object }
- { "success?" boolean }
-}
-{ $description "Unifies the two following the environment in that environment." } ;
-
-HELP: varo
-{ $var-description "A logic predicate. " { $snippet "varo" } " takes a argument and is true if it is a logic variable with no value." }
-{ $syntax "{ varo X }" }
-{ $see-also nonvaro } ;
-
-HELP: writenlo
-{ $var-description "A logic predicate. print a single sequence or string and return a new line." }
-{ $syntax "{ writenlo X }" }
-{ $see-also writeo nlo } ;
-
-HELP: writeo
-{ $var-description "A logic predicate. print a single sequence or string of characters." }
-{ $syntax "{ writeo X }" }
-{ $see-also writenlo nlo } ;
-
-ARTICLE: "factlog" "How to use factlog"
-{ $vocab-link "factlog" }
-" is an embedded language that runs on "{ $url "https://github.com/factor/factor" "Factor" } " with the capabilities of a subset of Prolog." $nl
-"It is an extended port from tiny_prolog and its descendants, " { $url "https://github.com/preston/ruby-prolog" "ruby-prolog" } "." $nl
-{ $code
-"USE: factlog
-
-LOGIC-PREDS: cato mouseo creatureo ;
-LOGIC-VARS: X Y ;
-SYMBOLS: Tom Jerry Nibbles ;"
-} $nl
-"In factlog, words that represent relationships are called " { $strong "logic predicates" } ". Use " { $link \ LOGIC-PREDS: } " to declare the predicates you want to use. " { $strong "Logic variables" } " are used to represent relationships. use " { $link \ LOGIC-VARS: } " to declare the logic variables you want to use." $nl
-"In the above code, logic predicates end with the character 'o', which is a convention borrowed from miniKanren and so on, and means relation. This is not necessary, but it is useful for reducing conflicts with the words of, the parent language, Factor. We really want to write them as: " { $snippet "cat°" } ", " { $snippet "mouse°" } " and " { $snippet "creature°" } ", but we use 'o' because it's easy to type." $nl
-{ $strong "Goals" } " are questions that factlog tries to meet to be true. To represent a goal, write an array with a logic predicate followed by zero or more arguments. factlog converts such definitions to internal representations." $nl
-{ $code "{ LOGIC-PREDICATE ARG1 ARG2 ... }" }
-{ $code "{ LOGIC-PREDICATE }" } $nl
-"We will write factlog programs using these goals." $nl
-{ $code
-"{ cato Tom } fact
-{ mouseo Jerry } fact
-{ mouseo Nibbles } fact"
-} $nl
-"The above code means that Tom is a cat and Jerry and Nibbles are mice. Use " { $link fact } " to describe the " { $strong "facts" } "." $nl
-{ $unchecked-example
-"{ cato Tom } query ."
-"t"
-} $nl
-"The above code asks, \"Is Tom a cat?\". We said,\"Tom is a cat.\", so the answer is " { $link t } ". The general form of a query is:" $nl
-{ $code "{ G1 G2 ... Gn } query" } $nl
-"The parentheses are omitted because there was only one goal to be satisfied earlier, but here is an example of two goals:" $nl
-{ $unchecked-example
-"{ { cato Tom } { cato Jerry } } query ."
-"f"
-} $nl
-"Tom is a cat, but Jerry is not declared a cat, so " { $link f } " is returned in response to this query." $nl
-"If you query with logic variable(s), you will get the answer for the logic variable(s). For such queries, an array of hashtables with logic variables as keys is returned." $nl
-{ $unchecked-example
-"{ mouseo X } query ."
-"{ H{ { X Jerry } } H{ { X Nibbles } } }"
-} $nl
-"The following code shows that if something is a cat, it's a creature. Use " { $link rule } " to write " { $strong "rules" } "." $nl
-{ $code
- "{ creatureo X } { cato X } rule"
-} $nl
-"According to the rules above, \"Tom is a creature.\" is answered to the following questions:" $nl
-{ $unchecked-example
-"{ creatureo Y } query ."
-"{ H{ { Y Tom } } }"
-} $nl
-"The general form of " { $link rule } " is:" $nl
-{ $code "Gh { Gb1 Gb2 ... Gbn } rule" } $nl
-"This means " { $snippet "Gh" } " when all goals of " { $snippet "Gb1" } ", " { $snippet "Gb2" } ", ..., " { $snippet "Gbn" } " are met. This " { $snippet "Gb1 Gb2 ... Gbn" } " is a " { $strong "conjunction" } "." $nl
-{ $unchecked-example
-"LOGIC-PREDS: youngo young-mouseo ;
-
-{ youngo Nibbles } fact
-
-{ young-mouseo X } {
- { mouseo X }
- { youngo X }
-} rule
-
-{ young-mouseo X } query ."
-"{ H{ { X Nibbles } } }"
-} $nl
-"This " { $snippet "Gh" } " is called " { $strong "head" } " and the " { $snippet "{ Gb 1Gb 2... Gbn }" } " is called " { $strong "body" } "." $nl
-"Facts are rules where its body is an empty array. So, the form of " { $link fact } " is:" $nl
-{ $code "Gh fact" } $nl
-"Let's describe that mice are also creatures." $nl
-{ $unchecked-example
-"{ creatureo X } { mouseo X } rule
-
-{ creatureo X } query ."
-"{ H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } } }"
-} $nl
-"To tell the truth, we were able to describe at once that cats and mice were creatures by doing the following." $nl
-{ $code
-"LOGIC-PREDS: creatureo ;
-
-{ creatureo Y } {
- { cato Y } ;; { mouseo Y }
-} rule"
-} $nl
-{ $link ;; } " is used to represent " { $strong "disjunction" } ". The following two forms are equivalent:" $nl
-{ $code "Gh { Gb1 Gb2 Gb3 ;; Gb4 Gb5 ;; Gb6 } rule" }
-$nl
-{ $code
- "Gh { Gb1 Gb2 Gb3 } rule"
- "Gh { Gb4 Gb5 } rule"
- "Gh { Gb6 } rule"
-} $nl
-"factlog actually converts the disjunction in that way. You may need to be careful about that when deleting definitions that you registered using " { $link rule } ", etc." $nl
-"You can use " { $link query-n } " to limit the number of answers to a query. Specify a number greater than or equal to 1." $nl
-{ $unchecked-example
-"{ creatureo Y } 2 query-n ."
-"{ H{ { Y Tom } } H{ { Y Jerry } } }"
-} $nl
-"Use " { $link \+ } " to express " { $strong "negation" } ". " { $link \+ } " acts on the goal immediately following it." $nl
-{ $unchecked-example
-"LOGIC-PREDS: likes-cheeseo dislikes-cheeseo ;
-
-{ likes-cheeseo X } { mouseo X } rule
-
-{ dislikes-cheeseo Y } {
- { creatureo Y }
- \\+ { likes-cheeseo Y }
-} rule"
-"{ dislikes-cheeseo Jerry } query ."
-"{ dislikes-cheeseo Tom } query ."
-"f\nt"
-} $nl
-"Other creatures might also like cheese..." $nl
-"You can also use sequences, lists, and tuples as goal definition arguments." $nl
-"The syntax of list descriptions allows you to describe \"head\" and \"tail\" of a list." $nl
-{ $code "L{ HEAD . TAIL }" }
-{ $code "L{ ITEM1 ITEM2 ITEM3 . OTHERS }" } $nl
-"You can also write a quotation that returns an argument as a goal definition argument." $nl
-{ $code "[ Tom Jerry Nibbles L{ } cons cons cons ]" } $nl
-"When written as an argument to a goal definition, the following lines have the same meaning as above:" $nl
-{ $code "L{ Tom Jerry Nibbles }" }
-{ $code "L{ Tom Jerry Nibbles . L{ } }" }
-{ $code "[ { Tom Jerry Nibbles } >list } ]" } $nl
-"Such quotations are called only once when converting the goal definitions to internal representations." $nl
-{ $link membero } " is a built-in logic predicate for the relationship an element is in a list." $nl
-{ $unchecked-example
- "SYMBOL: Spike
-{ membero Jerry L{ Tom Jerry Nibbles } } query .
-{ membero Spike [ Tom Jerry Nibbles L{ } cons cons cons ] } query ."
-"t\nf"
-} $nl
-"Recently, they moved into a small house. The house has a living room, a dining room and a kitchen. Well, humans feel that way. Each of them seems to be in their favorite room." $nl
-{ $code
-"TUPLE: house living dining kitchen in-the-wall ;
-LOGIC-PREDS: houseo ;
-
-{ houseo T{ house { living Tom } { dining f } { kitchen Nibbles } { in-the-wall Jerry } } } fact"
-} $nl
-"Don't worry about not mentioning the bathroom." $nl
-"Let's ask who is in the kitchen." $nl
-{ $unchecked-example
-"{ houseo T{ house { living __ } { dining __ } { kitchen X } { in-the-wall __ } } } query ."
-"{ H{ { X Nibbles } } }"
-} $nl
-"These two consecutive underbars are called " { $strong "anonymous logic variables" } ". Use in place of a regular logic variable when you do not need its name and value." $nl
-"It seems to be meal time. What do they eat?" $nl
-{ $code
-"LOGIC-PREDS: is-ao consumeso ;
-SYMBOLS: mouse cat milk cheese fresh-milk Emmentaler ;
-
-{
- { is-ao Tom cat }
- { is-ao Jerry mouse }
- { is-ao Nibbles mouse }
- { is-ao fresh-milk milk }
- { is-ao Emmentaler cheese }
-} facts
-
-{
- {
- { consumeso X milk } {
- { is-ao X mouse } ;;
- { is-ao X cat }
- }
- }
- { { consumeso X cheese } { is-ao X mouse } }
- { { consumeso X mouse } { is-ao X cat } }
-} rules"
-} $nl
-"Here, " { $link facts } " and " { $link rules } " are used. They can be used for successive facts or rules." $nl
-"Let's ask what Jerry consumes." $nl
-{ $unchecked-example
-"{ { consumeso Jerry X } { is-ao Y X } } query ."
-"{
- H{ { X milk } { Y fresh-milk } }
- H{ { X cheese } { Y Emmentaler } }
-}"
-} $nl
-"Well, what about Tom?" $nl
-{ $unchecked-example
-"{ { consumeso Tom X } { is-ao Y X } } query ."
-"{
- H{ { X milk } { Y fresh-milk } }
- H{ { X mouse } { Y Jerry } }
- H{ { X mouse } { Y Nibbles } }
-}"
-} $nl
-"This is a problematical answer. We have to redefine " { $snippet "consumeso" } "." $nl
-{ $code
-"LOGIC-PREDS: consumeso ;
-
-{ consumeso X milk } {
- { is-ao X mouse } ;;
- { is-ao X cat }
-} rule
-
-{ consumeso X cheese } { is-ao X mouse } rule
-{ consumeso Tom mouse } { !! f } rule
-{ consumeso X mouse } { is-ao X cat } rule"
-} $nl
-"We wrote about Tom before about common cats. What two consecutive exclamation marks represent is called a " { $strong "cut" } " operator. Use the cut operator to suppress " { $strong "backtracking" } "." $nl
-"The next letter " { $link f } " is an abbreviation for goal { " { $link failo } " } using the built-in logic predicate " { $link failo } ". { " { $link failo } " } is a goal that is always " { $link f } ". Similarly, there is a goal { " { $link trueo } " } that is always " { $link t } ", and its abbreviation is " { $link t } "." $nl
-"By these actions, \"Tom consumes mice.\" becomes false and suppresses the examination of general eating habits of cats." $nl
-{ $unchecked-example
-"{ { consumeso Tom X } { is-ao Y X } } query ."
-"{ H{ { X milk } { Y fresh-milk } } }"
-} $nl
-"It's OK. Let's check a cat that is not Tom." $nl
-{ $unchecked-example
-"SYMBOL: a-cat
-{ is-ao a-cat cat } fact
-
-{ { consumeso a-cat X } { is-ao Y X } } query ."
-"{
- H{ { X milk } { Y fresh-milk } }
- H{ { X mouse } { Y Jerry } }
- H{ { X mouse } { Y Nibbles } }
-}"
-} $nl
-"Jerry, watch out for the other cats." $nl
-"So far, we've seen how to define a logic predicate with " { $link fact } ", " { $link rule } ", " { $link facts } ", and " { $link rules } ". Each time you use those words for a logic predicate, information is added to it." $nl
-"You can clear these definitions with " { $link clear-pred } " for a logic predicate." $nl
-{ $unchecked-example
-"cato clear-pred
-mouseo clear-pred
-{ creatureo X } query ."
-"f"
-} $nl
-{ $link fact } " and " { $link rule } " add a new definition to the end of a logic predicate, while " { $link fact* } " and " { $link rule* } " add them first. The order of the information can affect the results of a query." $nl
-{ $unchecked-example
-"{ cato Tom } fact
-{ mouseo Jerry } fact
-{ mouseo Nibbles } fact*
-
-{ mouseo Y } query .
-
-{ creatureo Y } 2 query-n ."
-"{ H{ { Y Nibbles } } H{ { Y Jerry } } }\n{ H{ { Y Tom } } H{ { Y Nibbles } } }"
-} $nl
-"While " { $link clear-pred } " clears all the definition information for a given logic predicate, " { $link retract } " and " { $link retract-all } " provide selective clearing." $nl
-{ $link retract } " removes the first definition that matches the given head information." $nl
-{ $unchecked-example
-"{ mouseo Jerry } retract
-{ mouseo X } query ."
-"{ H{ { X Nibbles } } }"
-} $nl
-"On the other hand, " { $link retract-all } " removes all definitions that match a given head goal definition. Logic variables, including anonymous logic variables, can be used as goal definition arguments in " { $link retract } " and " { $link retract-all } ". A logic variable match any argument." $nl
-{ $unchecked-example
-"{ mouseo Jerry } fact
-{ mouseo X } query .
-
-{ mouseo __ } retract-all
-{ mouseo X } query ."
-"{ H{ { X Nibbles } } H{ { X Jerry } } }\nf"
-} $nl
-"let's have them come back." $nl
-{ $unchecked-example
-"{ { mouseo Jerry } { mouseo Nibbles } } facts
-{ creatureo X } query ."
-"{ H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } } }"
-} $nl
-"Logic predicates that take different numbers of arguments are treated separately. The previously used " { $snippet "cato" } " took one argument. Let's define " { $snippet "cato" } " that takes two arguments." $nl
-{ $unchecked-example
-"SYMBOLS: big small a-big-cat a-small-cat ;
-
-{ cato big a-big-cat } fact
-{ cato small a-small-cat } fact
-
-{ cato X } query .
-{ cato X Y } query .
-{ creatureo X } query ."
-"{ H{ { X Tom } } }\n{ H{ { X big } { Y a-big-cat } } H{ { X small } { Y a-small-cat } } }\n{ H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } }"
-} $nl
-"If you need to identify a logic predicate that has a different " { $strong "arity" } ", that is numbers of arguments, express it with a slash and an arity number. For example, " { $snippet "cato" } " with arity 1 is " { $snippet "cato/1" } ", " { $snippet "cato" } " with arity 2 is " { $snippet "cato/2" } ". But, note that factlog does not recognize these names." $nl
-{ $link clear-pred } " will clear all definitions of any arity. If you only want to remove the definition of a certain arity, you should use " { $link retract-all } " with logic variables." $nl
-{ $unchecked-example
-"{ cato __ __ } retract-all
-{ cato X Y } query ."
-"{ cato X } query ."
-"f\n{ H{ { X Tom } } }"
-} $nl
-"You can " { $strong "trace" } " factlog's execution. The word to do this is " { $link trace } "." $nl
-"The word to stop tracing is " { $link notrace } "." $nl
-"Here is a Prolog definition for the factorial predicate " { $snippet "factorial" } "." $nl
-"factorial(0, 1)." $nl
-"factorial(N, F) :- N > 0, N2 is N - 1, factorial(N2, F2), F is F2 * N." $nl
-"Let's think about how to do the same thing with factlog. It is mostly the following code, but is surrounded by backquotes where it has not been explained." $nl
-{ $code
-"USE: factlog
-
-LOGIC-PREDS: factorialo ;
-LOGIC-VARS: N N2 F F2 ;
-
-{ factorialo 0 1 } fact
-{ factorialo N F } {
- `N > 0`
- `N2 is N - 1`
- { factorialo N2 F2 }
- `F is F2 * N`
-} rule"
-} $nl
-"Within these backquotes are comparisons, calculations, and assignments (to be precise, " { $strong "unifications" } "). factlog has a mechanism to call Factor code to do these things. Here are some example." $nl
-{ $code "LOGIC-PREDS: N_>_0 N2_is_N_-_1 F_is_F2_*_N ;" }
-{ $code "{ N_>_0 N } [ N of 0 > ] callback" }
-{ $code "{ N2_is_N_-_1 N2 N } [ dup N of 1 - N2 unify ] callback" }
-{ $code "{ F_is_F2_*_N F F2 N } [ dup [ F2 of ] [ N of ] bi * F unify ] callback" } $nl
-"Use " { $link callback } " to set the quotation to be called. Such quotations take an " { $strong "environment" } " which holds the binding of logic variables, and returns " { $link t } " or " { $link f } " as a result of execution. To retrieve the values of logic variables in the environment, use " { $link of } " or " { $link at } "." $nl
-"The word " { $link unify } " unifies the two following the environment in that environment." $nl
-"Now we can rewrite the definition of factorialo to use them." $nl
-{ $code
-"USE: factlog
-
-LOGIC-PREDS: factorialo N_>_0 N2_is_N_-_1 F_is_F2_*_N ;
-LOGIC-VARS: N N2 F F2 ;
-
-{ factorialo 0 1 } fact
-{ factorialo N F } {
- { N_>_0 N }
- { N2_is_N_-_1 N2 N }
- { factorialo N2 F2 }
- { F_is_F2_*_N F F2 N }
-} rule
-
-{ N_>_0 N } [ N of 0 > ] callback
-
-{ N2_is_N_-_1 N2 N } [ dup N of 1 - N2 unify ] callback
-
-{ F_is_F2_*_N F F2 N } [ dup [ N of ] [ F2 of ] bi * F unify ] callback"
-} $nl
-"Let's try " { $snippet "factorialo" } "." $nl
-{ $unchecked-example
-"{ factorialo 0 F } query ."
-"{ H{ { F 1 } } }"
-}
-{ $unchecked-example
-"{ factorialo 1 F } query ."
-"{ H{ { F 1 } } }"
-}
-{ $unchecked-example
-"{ factorialo 10 F } query ."
-"{ H{ { F 3628800 } } }"
-} $nl
-"factlog has features that make it easier to meet the typical requirements shown here." $nl
-"There are the built-in logic predicates " { $link (<) } ", " { $link (>) } ", " { $link (>=) } ", and " { $link (=<) } " to compare numbers. There are also " { $link (==) } " and " { $link (\==) } " to test for equality and inequality of two arguments." $nl
-"The word " { $link is } " takes a quotation and a logic variable to be unified. The quotation takes an environment and returns a value. And " { $link is } " returns the internal representation of the goal. " { $link is } " is intended to be used in a quotation. If there is a quotation in the definition of " { $link rule } ", factlog uses the internal definition of the goal obtained by calling it." $nl
-"If you use these features to rewrite the definition of " { $snippet "factorialo" } ":" $nl
-{ $code
-"USE: factlog
-
-LOGIC-PREDS: factorialo ;
-LOGIC-VARS: N N2 F F2 ;
-
-{ factorialo 0 1 } fact
-{ factorialo N F } {
- { (>) N 0 }
- [ [ N of 1 - ] N2 is ]
- { factorialo N2 F2 }
- [ [ [ F2 of ] [ N of ] bi * ] F is ]
-} rule"
-} $nl
-"Use the built-in logic predicate " { $link (=) } " for unification that does not require processing with a quotation. " { $link (\=) } " will be true when such a unification fails. Note that " { $link (\=) } " does not actually do the unification." $nl
-{ $link varo } " takes a argument and is true if it is a logic variable with no value. On the other hand, " { $link nonvaro } " is true if its argument is not a logic variable or is a concrete logic variable." $nl
-"Now almost everything about factlog is explained."
-;
-
-ABOUT: "factlog"
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test factlog lists assocs math kernel namespaces
-accessors sequences
-factlog.examples.factorial
-factlog.examples.fib
-factlog.examples.fib2
-factlog.examples.hanoi
-factlog.examples.hanoi2
-factlog.examples.money
-factlog.examples.zebra
-factlog.examples.zebra2 ;
-
-IN: factlog.tests
-
-LOGIC-PREDS: cato mouseo creatureo ;
-LOGIC-VARS: X Y ;
-SYMBOLS: Tom Jerry Nibbles ;
-{ cato Tom } fact
-{ mouseo Jerry } fact
-{ mouseo Nibbles } fact
-
-{ t } [ { cato Tom } query ] unit-test
-{ f } [ { { cato Tom } { cato Jerry } } query ] unit-test
-{ { H{ { X Jerry } } H{ { X Nibbles } } } } [
- { mouseo X } query
-] unit-test
-
-{ creatureo X } { cato X } rule
-
-{ { H{ { Y Tom } } } } [ { creatureo Y } query ] unit-test
-
-LOGIC-PREDS: youngo young-mouseo ;
-{ youngo Nibbles } fact
-{ young-mouseo X } {
- { mouseo X }
- { youngo X }
-} rule
-
-{ { H{ { X Nibbles } } } } [ { young-mouseo X } query ] unit-test
-
-{ creatureo X } { mouseo X } rule
-
-{ { H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } } } } [
- { creatureo X } query
-] unit-test
-
-creatureo clear-pred
-{ creatureo Y } {
- { cato Y } ;; { mouseo Y }
-} rule
-{ "cato" } [
- creatureo get defs>> first second first pred>> name>>
-] unit-test
-{ "mouseo" } [
- creatureo get defs>> second second first pred>> name>>
-] unit-test
-
-creatureo clear-pred
-{ creatureo Y } {
- { cato Y } ;; { mouseo Y }
-} rule*
-{ "cato" } [
- creatureo get defs>> first second first pred>> name>>
-] unit-test
-{ "mouseo" } [
- creatureo get defs>> second second first pred>> name>>
-] unit-test
-
-{ { H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } } } } [
- { creatureo X } query
-] unit-test
-
-{ { H{ { Y Tom } } H{ { Y Jerry } } } } [
- { creatureo Y } 2 query-n
-] unit-test
-
-SYMBOL: Spike
-LOGIC-PREDS: dogo ;
-{ dogo Spike } fact
-creatureo clear-pred
-{ creatureo X } { dogo X } rule
-{ creatureo Y } {
- { cato Y } ;; { mouseo Y }
-} rule
-{ "dogo" } [
- creatureo get defs>> first second first pred>> name>>
-] unit-test
-{ "cato" } [
- creatureo get defs>> second second first pred>> name>>
-] unit-test
-{ "mouseo" } [
- creatureo get defs>> third second first pred>> name>>
-] unit-test
-
-creatureo clear-pred
-{ creatureo X } { dogo X } rule
-{ creatureo Y } {
- { cato Y } ;; { mouseo Y }
-} rule*
-{ "cato" } [
- creatureo get defs>> first second first pred>> name>>
-] unit-test
-{ "mouseo" } [
- creatureo get defs>> second second first pred>> name>>
-] unit-test
-{ "dogo" } [
- creatureo get defs>> third second first pred>> name>>
-] unit-test
-
-creatureo clear-pred
-{ creatureo Y } {
- { cato Y } ;; { mouseo Y }
-} rule
-
-LOGIC-PREDS: likes-cheeseo dislikes-cheeseo ;
-{ likes-cheeseo X } { mouseo X } rule
-{ dislikes-cheeseo Y } {
- { creatureo Y }
- \+ { likes-cheeseo Y }
-} rule
-
-{ f } [ { dislikes-cheeseo Jerry } query ] unit-test
-{ t } [ { dislikes-cheeseo Tom } query ] unit-test
-
-{ L{ Tom Jerry Nibbles } } [ L{ Tom Jerry Nibbles } ] unit-test
-{ t } [ { membero Jerry L{ Tom Jerry Nibbles } } query ] unit-test
-
-{ f } [
- { membero Spike [ Tom Jerry Nibbles L{ } cons cons cons ] } query
-] unit-test
-
-TUPLE: house living dining kitchen in-the-wall ;
-LOGIC-PREDS: houseo ;
-{ houseo T{ house
- { living Tom }
- { dining f }
- { kitchen Nibbles }
- { in-the-wall Jerry }
- }
-} fact
-
-{ { H{ { X Nibbles } } } } [
- { houseo T{ house
- { living __ }
- { dining __ }
- { kitchen X }
- { in-the-wall __ }
- }
- } query
-] unit-test
-
-LOGIC-PREDS: is-ao consumeso ;
-SYMBOLS: mouse cat milk cheese fresh-milk Emmentaler ;
-{
- { is-ao Tom cat }
- { is-ao Jerry mouse }
- { is-ao Nibbles mouse }
- { is-ao fresh-milk milk }
- { is-ao Emmentaler cheese }
-} facts
-{
- {
- { consumeso X milk } {
- { is-ao X mouse } ;;
- { is-ao X cat }
- }
- }
- { { consumeso X cheese } { is-ao X mouse } }
- { { consumeso Tom mouse } { !! f } }
- { { consumeso X mouse } { is-ao X cat } }
-} rules
-
-{
- {
- H{ { X milk } { Y fresh-milk } }
- H{ { X cheese } { Y Emmentaler } }
- }
-} [
- { { consumeso Jerry X } { is-ao Y X } } query
-] unit-test
-{ { H{ { X milk } { Y fresh-milk } } } } [
- { { consumeso Tom X } { is-ao Y X } } query
-] unit-test
-
-SYMBOL: a-cat
-{ is-ao a-cat cat } fact
-{ {
- H{ { X milk } { Y fresh-milk } }
- H{ { X mouse } { Y Jerry } }
- H{ { X mouse } { Y Nibbles } }
- }
-} [
- { { consumeso a-cat X } { is-ao Y X } } query
-] unit-test
-
-cato clear-pred
-mouseo clear-pred
-{ f } [ { creatureo X } query ] unit-test
-
-{ cato Tom } fact
-{ mouseo Jerry } fact
-{ mouseo Nibbles } fact*
-{ { H{ { Y Nibbles } } H{ { Y Jerry } } } } [
- { mouseo Y } query
-] unit-test
-
-{ mouseo Jerry } retract
-{ { H{ { X Nibbles } } } } [
- { mouseo X } query
-] unit-test
-
-{ mouseo Jerry } fact
-{ { H{ { X Nibbles } } H{ { X Jerry } } } } [
- { mouseo X } query
-] unit-test
-{ mouseo __ } retract-all
-{ f } [ { mouseo X } query ] unit-test
-
-{ { mouseo Jerry } { mouseo Nibbles } } facts
-SYMBOLS: big small a-big-cat a-small-cat ;
-{ cato big a-big-cat } fact
-{ cato small a-small-cat } fact
-{ { H{ { X Tom } } } } [ { cato X } query ] unit-test
-{
- {
- H{ { X big } { Y a-big-cat } }
- H{ { X small } { Y a-small-cat } }
- }
-} [ { cato X Y } query ] unit-test
-{
- { H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } } }
-} [ { creatureo X } query ] unit-test
-
-{ cato __ __ } retract-all
-{ f } [ { cato X Y } query ] unit-test
-{ { H{ { X Tom } } } } [ { cato X } query ] unit-test
-
-LOGIC-PREDS: factorialo N_>_0 N2_is_N_-_1 F_is_F2_*_N ;
-LOGIC-VARS: N N2 F F2 ;
-{ factorialo 0 1 } fact
-{ factorialo N F } {
- { N_>_0 N }
- { N2_is_N_-_1 N2 N }
- { factorialo N2 F2 }
- { F_is_F2_*_N F F2 N }
-} rule
-{ N_>_0 N } [ N of 0 > ] callback
-{
- { { N2_is_N_-_1 N2 N } [ dup N of 1 - N2 unify ] }
- { { F_is_F2_*_N F F2 N } [ dup [ N of ] [ F2 of ] bi * F unify ] }
-} callbacks
-
-{ { H{ { F 1 } } } } [ { factorialo 0 F } query ] unit-test
-{ { H{ { F 1 } } } } [ { factorialo 1 F } query ] unit-test
-{ { H{ { F 3628800 } } } } [ { factorialo 10 F } query ] unit-test
-
-factorialo clear-pred
-{ factorialo 0 1 } fact
-{ factorialo N F } {
- { (>) N 0 }
- [ [ N of 1 - ] N2 is ]
- { factorialo N2 F2 }
- [ [ [ F2 of ] [ N of ] bi * ] F is ]
-} rule
-
-{ { H{ { F 1 } } } } [ { factorialo 0 F } query ] unit-test
-{ { H{ { F 1 } } } } [ { factorialo 1 F } query ] unit-test
-{ { H{ { F 3628800 } } } } [ { factorialo 10 F } query ] unit-test
+++ /dev/null
-! Copyright (C) 2019-2020 KUSUMOTO Norio.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes classes.tuple combinators
-combinators.short-circuit compiler.units continuations
-formatting fry io kernel lexer lists locals make math multiline
-namespaces parser prettyprint prettyprint.backend prettyprint.config
-prettyprint.custom prettyprint.sections quotations sequences
-sequences.deep sets splitting strings words words.symbol
-vectors ;
-
-IN: factlog
-
-SYMBOL: !! ! cut operator in prolog: !
-SYMBOL: __ ! anonymous variable in prolog: _
-SYMBOL: ;; ! disjunction, or in prolog: ;
-SYMBOL: \+ ! negation in prolog: not, \+
-
-<PRIVATE
-
-<<
-TUPLE: logic-pred name defs ;
-
-: <pred> ( name -- pred )
- logic-pred new
- swap >>name
- V{ } clone >>defs ;
-
-MIXIN: LOGIC-VAR
-SINGLETON: NORMAL-LOGIC-VAR
-SINGLETON: ANONYMOUSE-LOGIC-VAR
-INSTANCE: NORMAL-LOGIC-VAR LOGIC-VAR
-INSTANCE: ANONYMOUSE-LOGIC-VAR LOGIC-VAR
-
-: logic-var? ( obj -- ? )
- dup symbol? [ get LOGIC-VAR? ] [ drop f ] if ; inline
-
-SYMBOLS: *trace?* *trace-depth* ;
-
-PRIVATE>
-
-: trace ( -- ) t *trace?* set-global ;
-
-: notrace ( -- ) f *trace?* set-global ;
-
-SYNTAX: LOGIC-VARS: ";"
- [
- create-word-in
- [ reset-generic ]
- [ define-symbol ]
- [ NORMAL-LOGIC-VAR swap set-global ] tri
- ] each-token ;
-
-SYNTAX: LOGIC-PREDS: ";"
- [
- create-word-in
- [ reset-generic ]
- [ define-symbol ]
- [ [ name>> <pred> ] keep set-global ] tri
- ] each-token ;
->>
-
-SYNTAX: %!
- "!%" parse-multiline-string drop ;
-
-<PRIVATE
-
-TUPLE: logic-goal pred args ;
-
-: called-args ( args -- args' )
- [ dup callable? [ call( -- term ) ] when ] map ;
-
-:: <goal> ( pred args -- goal )
- pred get args called-args logic-goal boa ; inline
-
-: def>goal ( goal-def -- goal ) unclip swap <goal> ; inline
-
-: normalize ( goal-def/defs -- goal-defs )
- dup {
- [ !! = ]
- [ ?first dup symbol? [ get logic-pred? ] [ drop f ] if ]
- } 1|| [ 1array ] when ;
-
-TUPLE: logic-env table ;
-
-: <env> ( -- env ) logic-env new H{ } clone >>table ; inline
-
-:: env-put ( x pair env -- ) pair x env table>> set-at ; inline
-
-: env-get ( x env -- pair/f ) table>> at ; inline
-
-: env-delete ( x env -- ) table>> delete-at ; inline
-
-: env-clear ( env -- ) table>> clear-assoc ; inline
-
-: dereference ( term env -- term' env' )
- [ 2dup env-get [ 2nip first2 t ] [ f ] if* ] loop ;
-
-PRIVATE>
-
-M: logic-env at*
- dereference {
- { [ over logic-goal? ] [
- [ [ pred>> ] [ args>> ] bi ] dip at <goal> t ] }
- { [ over tuple? ] [
- '[ tuple-slots [ _ at ] map ]
- [ class-of slots>tuple ] bi t ] }
- { [ over sequence? ] [
- '[ _ at ] map t ] }
- [ drop t ]
- } cond ;
-
-<PRIVATE
-
-TUPLE: callback-env env trail ;
-
-C: <callback-env> callback-env
-
-M: callback-env at* env>> at* ;
-
-TUPLE: cut-info cut? ;
-
-C: <cut> cut-info
-
-: cut? ( cut-info -- ? ) cut?>> ; inline
-
-: set-info ( ? cut-info -- ) cut?<< ; inline
-
-: set-info-if-f ( ? cut-info -- )
- dup cut?>> [ 2drop ] [ cut?<< ] if ; inline
-
-DEFER: unify*
-
-:: (unify*) ( x! x-env! y! y-env! trail tmp-env -- success? )
- f :> ret-value! f :> ret?! f :> ret2?!
- t :> loop?!
- [ loop? ] [
- { { [ x logic-var? ] [
- x x-env env-get :> xp!
- xp not [
- y y-env dereference y-env! y!
- x y = x-env y-env eq? and [
- x { y y-env } x-env env-put
- x-env tmp-env eq? [
- { x x-env } trail push
- ] unless
- ] unless
- f loop?! t ret?! t ret-value!
- ] [
- xp first2 x-env! x!
- x x-env dereference x-env! x!
- ] if ] }
- { [ y logic-var? ] [
- x y x! y! x-env y-env x-env! y-env! ] }
- [ f loop?! ]
- } cond
- ] while
- ret? [
- t ret-value!
- x y [ logic-goal? ] both? [
- x pred>> y pred>> = [
- x args>> x! y args>> y!
- ] [
- f ret-value! t ret2?!
- ] if
- ] when
- ret2? [
- {
- { [ x y [ tuple? ] both? ] [
- x y [ class-of ] same? [
- x y [ tuple-slots ] bi@ :> ( x-slots y-slots )
- 0 :> i! x-slots length 1 - :> stop-i t :> loop?!
- [ i stop-i <= loop? and ] [
- x-slots y-slots [ i swap nth ] bi@
- :> ( x-item y-item )
- x-item x-env y-item y-env trail tmp-env unify* [
- f loop?!
- f ret-value!
- ] unless
- i 1 + i!
- ] while
- ] [ f ret-value! ] if ] }
- { [ x y [ sequence? ] both? ] [
- x y [ class-of ] same? x y [ length ] same? and [
- 0 :> i! x length 1 - :> stop-i t :> loop?!
- [ i stop-i <= loop? and ] [
- x y [ i swap nth ] bi@ :> ( x-item y-item )
- x-item x-env y-item y-env trail tmp-env unify* [
- f loop?!
- f ret-value!
- ] unless
- i 1 + i!
- ] while
- ] [ f ret-value! ] if ] }
- [ x y = ret-value! ]
- } cond
- ] unless
- ] unless
- ret-value ;
-
-:: unify* ( x x-env y y-env trail tmp-env -- success? )
- *trace?* get-global :> trace?
- 0 :> depth!
- trace? [
- *trace-depth* counter depth!
- depth [ "\t" printf ] times
- "Unification of " printf x-env x of pprint
- " and " printf y pprint nl
- ] when
- x x-env y y-env trail tmp-env (unify*) :> success?
- trace? [
- depth [ "\t" printf ] times
- success? [ "==> Success\n" ] [ "==> Fail\n" ] if "%s\n" printf
- *trace-depth* get-global 1 - *trace-depth* set-global
- ] when
- success? ;
-
-: each-until ( seq quot -- ) find 2drop ; inline
-
-:: resolve-body ( body env cut quot: ( -- ) -- )
- body empty? [
- quot call( -- )
- ] [
- body unclip :> ( rest-goals! first-goal! )
- first-goal !! = [ ! cut
- rest-goals env cut [ quot call( -- ) ] resolve-body
- t cut set-info
- ] [
- first-goal callable? [
- first-goal call( -- goal ) first-goal!
- ] when
- *trace?* get-global [
- first-goal
- [ pred>> name>> "in: { %s " printf ]
- [ args>> [ "%u " printf ] each "}\n" printf ] bi
- ] when
- <env> :> d-env!
- f <cut> :> d-cut!
- first-goal pred>> defs>> [
- first2 :> ( d-head d-body )
- first-goal d-head [ args>> length ] same? [
- d-cut cut? cut cut? or [ t ] [
- V{ } clone :> trail
- first-goal env d-head d-env trail d-env unify* [
- d-body callable? [
- d-env trail <callback-env> d-body call( cb-env -- ? ) [
- rest-goals env cut [ quot call( -- ) ] resolve-body
- ] when
- ] [
- d-body d-env d-cut [
- rest-goals env cut [ quot call( -- ) ] resolve-body
- cut cut? d-cut set-info-if-f
- ] resolve-body
- ] if
- ] when
- trail [ first2 env-delete ] each
- d-env env-clear
- f
- ] if
- ] [ f ] if
- ] each-until
- ] if
- ] if ;
-
-: split-body ( body -- bodies ) { ;; } split [ >array ] map ;
-
-SYMBOL: *anonymouse-var-no*
-
-: reset-anonymouse-var-no ( -- ) 0 *anonymouse-var-no* set-global ;
-
-: proxy-var-for-'__' ( -- var-symbol )
- [
- *anonymouse-var-no* counter "ANON-%d_" sprintf
- "factlog.private" create-word dup dup
- define-symbol
- ANONYMOUSE-LOGIC-VAR swap set-global
- ] with-compilation-unit ;
-
-: replace-'__' ( before -- after )
- {
- { [ dup __ = ] [ drop proxy-var-for-'__' ] }
- { [ dup sequence? ] [ [ replace-'__' ] map ] }
- { [ dup tuple? ] [
- [ tuple-slots [ replace-'__' ] map ]
- [ class-of slots>tuple ] bi ] }
- [ ]
- } cond ;
-
-: collect-logic-vars ( seq -- vars-array )
- [ logic-var? ] deep-filter members ;
-
-:: (resolve) ( goal-def/defs quot: ( env -- ) -- )
- goal-def/defs replace-'__' normalize [ def>goal ] map :> goals
- <env> :> env
- goals env f <cut> [ env quot call( env -- ) ] resolve-body ;
-
-: resolve ( goal-def/defs quot: ( env -- ) -- ) (resolve) ;
-
-: resolve* ( goal-def/defs -- ) [ drop ] resolve ;
-
-SYMBOL: dummy-item
-
-:: negation-goal ( goal -- negation-goal )
- "failo_" <pred> :> f-pred
- f-pred { } clone logic-goal boa :> f-goal
- V{ { f-goal [ drop f ] } } f-pred defs<<
- "trueo_" <pred> :> t-pred
- t-pred { } clone logic-goal boa :> t-goal
- V{ { t-goal [ drop t ] } } t-pred defs<<
- goal pred>> name>> "\\+%s_" sprintf <pred> :> negation-pred
- negation-pred goal args>> clone logic-goal boa :> negation-goal
- V{
- { negation-goal { goal !! f-goal } }
- { negation-goal { t-goal } }
- } negation-pred defs<< ! \+P_ { P !! { failo_ } ;; { trueo_ } } rule
- negation-goal ;
-
-SYMBOLS: at-the-beginning at-the-end ;
-
-:: (rule) ( head body pos -- )
- reset-anonymouse-var-no
- head replace-'__' def>goal :> head-goal
- body replace-'__' normalize
- split-body pos at-the-beginning = [ reverse ] when ! disjunction
- dup empty? [
- head-goal swap 2array 1vector
- head-goal pred>> [
- pos at-the-end = [ swap ] when append!
- ] change-defs drop
- ] [
- f :> negation?!
- [
- [
- {
- { [ dup \+ = ] [ drop dummy-item t negation?! ] }
- { [ dup array? ] [
- def>goal negation? [ negation-goal ] when
- f negation?! ] }
- { [ dup callable? ] [
- call( -- goal ) negation? [ negation-goal ] when
- f negation?! ] }
- { [ dup [ t = ] [ f = ] bi or ] [
- :> t/f! negation? [ t/f not t/f! ] when
- t/f "trueo_" "failo_" ? <pred> :> t/f-pred
- t/f-pred { } clone logic-goal boa :> t/f-goal
- V{ { t/f-goal [ drop t/f ] } } t/f-pred defs<<
- t/f-goal
- f negation?! ] }
- { [ dup !! = ] [ f negation?! ] } ! as '!!'
- [ drop dummy-item f negation?! ]
- } cond
- ] map dummy-item swap remove :> body-goals
- V{ { head-goal body-goals } }
- head-goal pred>> [
- pos at-the-end = [ swap ] when append!
- ] change-defs drop
- ] each
- ] if ;
-
-: (fact) ( head pos -- ) { } clone swap (rule) ;
-
-PRIVATE>
-
-: rule ( head body -- ) at-the-end (rule) ; inline
-
-: rule* ( head body -- ) at-the-beginning (rule) ; inline
-
-: rules ( defs -- ) [ first2 rule ] each ; inline
-
-: fact ( head -- ) at-the-end (fact) ; inline
-
-: fact* ( head -- ) at-the-beginning (fact) ; inline
-
-: facts ( defs -- ) [ fact ] each ; inline
-
-:: callback ( head quot: ( callback-env -- ? ) -- )
- head def>goal :> head-goal
- head-goal pred>> [
- { head-goal quot } suffix!
- ] change-defs drop ;
-
-: callbacks ( defs -- ) [ first2 callback ] each ; inline
-
-:: retract ( head-def -- )
- head-def replace-'__' def>goal :> head-goal
- head-goal pred>> defs>> :> defs
- defs [ first <env> head-goal <env> V{ } clone <env> (unify*) ] find [
- head-goal pred>> [ remove-nth! ] change-defs drop
- ] [ drop ] if ;
-
-:: retract-all ( head-def -- )
- head-def replace-'__' def>goal :> head-goal
- head-goal pred>> defs>> :> defs
- defs [
- first <env> head-goal <env> V{ } clone <env> (unify*)
- ] reject! head-goal pred>> defs<< ;
-
-: clear-pred ( pred -- ) get V{ } clone swap defs<< ;
-
-:: unify ( cb-env x y -- success? )
- cb-env env>> :> env
- x env y env cb-env trail>> env (unify*) ;
-
-:: is ( quot: ( env -- value ) dist -- goal )
- quot collect-logic-vars
- dup dist swap member? [ dist suffix ] unless :> args
- quot dist "[ %u %s is ]" sprintf <pred> :> is-pred
- is-pred args logic-goal boa :> is-goal
- V{
- {
- is-goal
- [| env | env dist env quot call( env -- value ) unify ]
- }
- } is-pred defs<<
- is-goal ;
-
-:: =:= ( quot: ( env -- n m ) -- goal )
- quot collect-logic-vars :> args
- quot "[ %u =:= ]" sprintf <pred> :> =:=-pred
- =:=-pred args logic-goal boa :> =:=-goal
- V{
- {
- =:=-goal
- [| env |
- env quot call( env -- n m )
- 2dup [ number? ] both? [ = ] [ 2drop f ] if ]
- }
- } =:=-pred defs<<
- =:=-goal ;
-
-:: =\= ( quot: ( env -- n m ) -- goal )
- quot collect-logic-vars :> args
- quot "[ %u =\\= ]" sprintf <pred> :> =\=-pred
- =\=-pred args logic-goal boa :> =\=-goal
- V{
- {
- =\=-goal
- [| env |
- env quot call( env -- n m )
- 2dup [ number? ] both? [ = not ] [ 2drop f ] if ]
- }
- } =\=-pred defs<<
- =\=-goal ;
-
-:: invoke ( quot: ( env -- ) -- goal )
- quot collect-logic-vars :> args
- quot "[ %u invoke ]" sprintf <pred> :> invoke-pred
- invoke-pred args logic-goal boa :> invoke-goal
- V{
- { invoke-goal [| env | env quot call( env -- ) t ] }
- } invoke-pred defs<<
- invoke-goal ;
-
-:: invoke* ( quot: ( env -- ? ) -- goal )
- quot collect-logic-vars :> args
- quot "[ %u invoke* ]" sprintf <pred> :> invoke*-pred
- invoke*-pred args logic-goal boa :> invoke*-goal
- V{
- { invoke*-goal [| env | env quot call( env -- ? ) ] }
- } invoke*-pred defs<<
- invoke*-goal ;
-
-:: query-n ( goal-def/defs n/f -- bindings-array/success? )
- *trace?* get-global :> trace?
- 0 :> n!
- f :> success?!
- V{ } clone :> bindings
- [
- goal-def/defs normalize [| env |
- env table>> keys [ get NORMAL-LOGIC-VAR? ] filter
- [ dup env at ] H{ } map>assoc
- trace? get-global [ dup [ "%u: %u\n" printf ] assoc-each ] when
- bindings push
- t success?!
- n/f [
- n 1 + n!
- n n/f >= [ return ] when
- ] when
- ] (resolve)
- ] with-return
- bindings dup {
- [ empty? ]
- [ first keys [ get NORMAL-LOGIC-VAR? ] any? not ]
- } 1|| [ drop success? ] [ >array ] if ;
-
-: query ( goal-def/defs -- bindings-array/success? ) f query-n ;
-
-
-! Built-in predicate definitions -----------------------------------------------------
-
-LOGIC-PREDS:
- trueo failo
- varo nonvaro
- (<) (>) (>=) (=<) (==) (\==) (=) (\=)
- writeo writenlo nlo
- membero appendo lengtho listo
-;
-
-{ trueo } [ drop t ] callback
-
-{ failo } [ drop f ] callback
-
-
-<PRIVATE LOGIC-VARS: A B C X Y Z ; PRIVATE>
-
-{ varo X } [ X of logic-var? ] callback
-
-{ nonvaro X } [ X of logic-var? not ] callback
-
-
-{ (<) X Y } [
- [ X of ] [ Y of ] bi 2dup [ number? ] both? [ < ] [ 2drop f ] if
-] callback
-
-{ (>) X Y } [
- [ X of ] [ Y of ] bi 2dup [ number? ] both? [ > ] [ 2drop f ] if
-] callback
-
-{ (>=) X Y } [
- [ X of ] [ Y of ] bi 2dup [ number? ] both? [ >= ] [ 2drop f ] if
-] callback
-
-{ (=<) X Y } [
- [ X of ] [ Y of ] bi 2dup [ number? ] both? [ <= ] [ 2drop f ] if
-] callback
-
-{ (==) X Y } [ [ X of ] [ Y of ] bi = ] callback
-
-{ (\==) X Y } [ [ X of ] [ Y of ] bi = not ] callback
-
-{ (=) X Y } [ dup [ X of ] [ Y of ] bi unify ] callback
-
-{ (\=) X Y } [
- clone [ clone ] change-env [ clone ] change-trail
- dup [ X of ] [ Y of ] bi unify not
-] callback
-
-
-{ writeo X } [
- X of dup sequence? [
- [ dup string? [ printf ] [ pprint ] if ] each
- ] [
- dup string? [ printf ] [ pprint ] if
- ] if t
-] callback
-
-{ writenlo X } [
- X of dup sequence? [
- [ dup string? [ printf ] [ pprint ] if ] each
- ] [
- dup string? [ printf ] [ pprint ] if
- ] if nl t
-] callback
-
-{ nlo } [ drop nl t ] callback
-
-
-{ membero X L{ X . Z } } fact
-{ membero X L{ Y . Z } } { membero X Z } rule
-
-{ appendo L{ } A A } fact
-{ appendo L{ A . X } Y L{ A . Z } } {
- { appendo X Y Z }
-} rule
-
-
-<PRIVATE LOGIC-VARS: Tail N N1 ; PRIVATE>
-
-{ lengtho L{ } 0 } fact
-{ lengtho L{ __ . Tail } N } {
- { lengtho Tail N1 }
- [ [ N1 of 1 + ] N is ]
-} rule
-
-
-<PRIVATE LOGIC-VARS: L ; PRIVATE>
-
-{ listo L{ } } fact
-{ listo L{ __ . __ } } fact
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test factlog factlog.examples.factorial ;
+IN: factlog.examples.factorial.tests
+
+{ { H{ { F 1 } } } } [ { factorial 0 F } query ] unit-test
+
+{ { H{ { F 1 } } } } [ { factorial 1 F } query ] unit-test
+
+{ { H{ { F 2 } } } } [ { factorial 2 F } query ] unit-test
+
+{ { H{ { F 3628800 } } } } [ { factorial 10 F } query ] unit-test
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: factlog kernel assocs math ;
+IN: factlog.examples.factorial
+
+LOGIC-PREDS: factorial ;
+LOGIC-VARS: N F N2 F2 ;
+
+{ factorial N F } {
+ { (>) N 0 }
+ [ [ N of 1 - ] N2 is ]
+ { factorial N2 F2 }
+ [ [ [ F2 of ] [ N of ] bi * ] F is ] !!
+} rule
+{ factorial 0 1 } fact
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test factlog lists factlog.examples.fib ;
+IN: factlog.examples.fib.tests
+
+{ { H{ { L L{ 0 } } } } } [ { fibo 0 L } query ] unit-test
+
+{ { H{ { L L{ 1 1 0 } } } } } [ { fibo 2 L } query ] unit-test
+
+{ { H{ { L L{ 55 34 21 13 8 5 3 2 1 1 0 } } } } } [
+ { fibo 10 L } query
+] unit-test
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: factlog kernel lists assocs math ;
+IN: factlog.examples.fib
+
+LOGIC-PREDS: fibo ;
+LOGIC-VARS: F F1 F2 N N1 L ;
+
+{ fibo N L{ F F1 F2 . L } } {
+ { (>) N 1 }
+ [ [ N of 1 - ] N1 is ]
+ { fibo N1 L{ F1 F2 . L } }
+ [ [ [ F1 of ] [ F2 of ] bi + ] F is ] !!
+} rule
+
+{ fibo 0 L{ 0 } } !! rule
+
+{ fibo 1 L{ 1 0 } } fact
--- /dev/null
+! Copyright (C) 2019 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test factlog factlog.examples.fib2 ;
+IN: factlog.examples.fib2.tests
+
+{ { H{ { F 6765 } } } } [
+ { fibo 20 F } query
+] unit-test
--- /dev/null
+! Copyright (C) 2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: factlog kernel lists assocs locals math ;
+IN: factlog.examples.fib2
+
+LOGIC-PREDS: fibo ;
+LOGIC-VARS: F F1 F2 N N1 N2 ;
+
+{ fibo 1 1 } fact
+{ fibo 2 1 } fact
+{ fibo N F } {
+ { (>) N 2 }
+ [ [ N of 1 - ] N1 is ] { fibo N1 F1 }
+ [ [ N of 2 - ] N2 is ] { fibo N2 F2 }
+ [ [ [ F1 of ] [ F2 of ] bi + ] F is ]
+ [
+ [
+ [ N of ] [ F of ] bi
+ [let :> ( nv fv ) { fibo nv fv } !! rule* ]
+ ] invoke ]
+} rule
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test factlog factlog.examples.hanoi
+formatting sequences ;
+IN: factlog.examples.hanoi.tests
+
+{ t } [
+ {
+ "The following statements will be printed:"
+ "move disk from left to center"
+ "move disk from left to right"
+ "move disk from center to right"
+ "move disk from left to center"
+ "move disk from right to left"
+ "move disk from right to center"
+ "move disk from left to center"
+ " "
+ } [ "%s\n" printf ] each
+ { hanoi 3 } query
+] unit-test
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: factlog kernel assocs math ;
+IN: factlog.examples.hanoi
+
+LOGIC-PREDS: hanoi moveo informo ;
+LOGIC-VARS: A B C M N X Y ;
+SYMBOLS: left center right ;
+
+{ hanoi N } { moveo N left center right } rule
+
+{ moveo 0 __ __ __ } !! rule
+
+{ moveo N A B C } {
+ [ [ N of 1 - ] M is ]
+ { moveo M A C B }
+ { informo A B }
+ { moveo M C B A }
+} rule
+
+{ informo X Y } {
+ { writeo { "move disk from " X " to " Y } } { nlo }
+} rule
+
+
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test factlog lists factlog.examples.hanoi2
+formatting sequences ;
+IN: factlog.examples.hanoi2.tests
+
+{ t } [
+ {
+ "The following statements will be printed:"
+ "move Top from Left to Center"
+ "move 2nd from Left to Right"
+ "move Top from Center to Right"
+ "move Base from Left to Center"
+ "move Top from Right to Left"
+ "move 2nd from Right to Center"
+ "move Top from Left to Center"
+ " "
+ } [ "%s\n" printf ] each
+ { hanoi L{ "Base" "2nd" "Top" } "Left" "Center" "Right" } query
+] unit-test
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: factlog lists sequences assocs formatting ;
+IN: factlog.examples.hanoi2
+
+LOGIC-PREDS: hanoi write-move ;
+LOGIC-VARS: A B C X Y Z ;
+
+{ write-move X } [ X of [ printf ] each t ] callback
+
+{ hanoi L{ } A B C } fact
+
+{ hanoi L{ X . Y } A B C } {
+ { hanoi Y A C B }
+ { write-move { "move " X " from " A " to " B "\n" } }
+ { hanoi Y C B A }
+} rule
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test factlog lists factlog.examples.money ;
+IN: factlog.examples.money.tests
+
+{
+ {
+ H{
+ { N1 L{ 0 9 5 6 7 } }
+ { N2 L{ 0 1 0 8 5 } }
+ { N L{ 1 0 6 5 2 } }
+ }
+ }
+}
+[
+ { { moneyo N1 N2 N } { sumo N1 N2 N } } query
+ S-and-M-can't-be-zero
+] unit-test
+
+{
+ {
+ H{
+ { N1 L{ 5 2 6 4 8 5 } }
+ { N2 L{ 1 9 7 4 8 5 } }
+ { N L{ 7 2 3 9 7 0 } }
+ }
+ }
+}
+[
+ { { donaldo N1 N2 N } { sumo N1 N2 N } } query
+] unit-test
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: factlog lists assocs sequences kernel math
+locals formatting io ;
+IN: factlog.examples.money
+
+LOGIC-PREDS: sumo sum1o digitsumo delo donaldo moneyo ;
+LOGIC-VARS: S E N D M O R Y A L G B T
+ N1 N2 C C1 C2 D1 D2 L1
+ Digits Digs Digs1 Digs2 Digs3 ;
+
+{ sumo N1 N2 N } {
+ { sum1o N1 N2 N 0 0 L{ 0 1 2 3 4 5 6 7 8 9 } __ }
+} rule
+
+{ sum1o L{ } L{ } L{ } 0 0 Digits Digits } fact
+{ sum1o L{ D1 . N1 } L{ D2 . N2 } L{ D . N } C1 C Digs1 Digs } {
+ { sum1o N1 N2 N C1 C2 Digs1 Digs2 }
+ { digitsumo D1 D2 C2 D C Digs2 Digs }
+} rule
+
+{ digitsumo D1 D2 C1 D C Digs1 Digs } {
+ { delo D1 Digs1 Digs2 }
+ { delo D2 Digs2 Digs3 }
+ { delo D Digs3 Digs }
+ [ [ [ D1 of ] [ D2 of ] [ C1 of ] tri + + ] S is ]
+ [ [ S of 10 mod ] D is ]
+ [ [ S of 10 / >integer ] C is ]
+} rule
+
+{ delo A L L } { { nonvaro A } !! } rule
+{ delo A L{ A . L } L } fact
+{ delo A L{ B . L } L{ B . L1 } } { delo A L L1 } rule
+
+{ moneyo
+ L{ 0 S E N D }
+ L{ 0 M O R E }
+ L{ M O N E Y }
+} fact
+
+{ donaldo
+ L{ D O N A L D }
+ L{ G E R A L D }
+ L{ R O B E R T }
+} fact
+
+:: S-and-M-can't-be-zero ( seq -- seq' )
+ seq [| hash |
+ 1 hash N1 of list>array nth 0 = not
+ 1 hash N2 of list>array nth 0 = not and
+ ] filter ;
+
+:: print-puzzle ( hash-array -- )
+ hash-array
+ [| hash |
+ " " printf hash N1 of list>array [ "%d " printf ] each nl
+ "+ " printf hash N2 of list>array [ "%d " printf ] each nl
+ "----------------" printf nl
+ " " printf hash N of list>array [ "%d " printf ] each nl nl
+ ] each ;
--- /dev/null
+! Copyright (C) 2019 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test factlog factlog.examples.zebra-short ;
+IN: factlog.examples.zebra-short.tests
+
+{
+ { H{ { X japanese } } H{ { X japanese } } }
+}
+[ { zebrao X } query ] unit-test
+
--- /dev/null
+! Copyright (C) 2019 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: factlog arrays ;
+IN: factlog.examples.zebra-short
+
+! Do the same as this Prolog program
+!
+! neighbor(L,R,[L,R|_]).
+! neighbor(L,R,[_|Xs]) :- neighbor(L,R,Xs).
+!
+! zebra(X) :- Street = [H1,H2,H3],
+! member(house(red,english,_), Street),
+! member(house(_,spanish,dog), Street),
+! neighbor(house(_,_,cat), house(_,japanese,_), Street),
+! neighbor(house(_,_,cat), house(blue,_,_), Street),
+! member(house(_,X,zebra),Street).
+
+LOGIC-PREDS: neighboro zebrao ;
+LOGIC-VARS: L R X Xs H1 H2 H3 Street ;
+SYMBOLS: red blue ;
+SYMBOLS: english spanish japanese ;
+SYMBOLS: dog cat zebra ;
+TUPLE: house color nationality pet ;
+
+{ neighboro L R L{ L R . __ } } fact
+{ neighboro L R L{ __ . Xs } } { neighboro L R Xs } rule
+
+{ zebrao X } {
+ { (=) Street L{ H1 H2 H3 } }
+ { membero [ T{ house f red english __ } ] Street }
+ { membero [ T{ house f __ spanish dog } ] Street }
+ { neighboro [ T{ house f __ __ cat } ] [ T{ house f __ japanese __ } ] Street }
+ { neighboro [ T{ house f __ __ cat } ] [ T{ house f blue __ __ } ] Street }
+ { membero [ T{ house f __ X zebra } ] Street }
+} rule
+
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test factlog lists factlog.examples.zebra ;
+IN: factlog.examples.zebra.tests
+
+{
+ {
+ H{
+ {
+ Hs
+ L{
+ T{ house
+ { color yellow }
+ { nationality norwegian }
+ { drink water }
+ { smoke dunhill }
+ { pet cat }
+ }
+ T{ house
+ { color blue }
+ { nationality dane }
+ { drink tea }
+ { smoke blend }
+ { pet horse }
+ }
+ T{ house
+ { color red }
+ { nationality english }
+ { drink milk }
+ { smoke pall-mall }
+ { pet birds }
+ }
+ T{ house
+ { color green }
+ { nationality german }
+ { drink coffee }
+ { smoke prince }
+ { pet zebra }
+ }
+ T{ house
+ { color white }
+ { nationality swede }
+ { drink beer }
+ { smoke blue-master }
+ { pet dog }
+ }
+ }
+ }
+ { X norwegian }
+ { Y german }
+ }
+ }
+}
+[ { houseso Hs X Y } query ] unit-test
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+
+! Zebra Puzzle: https://rosettacode.org/wiki/Zebra_puzzle
+
+USING: factlog lists ;
+IN: factlog.examples.zebra
+
+LOGIC-PREDS: houseso neighboro zebrao watero nexto lefto ;
+LOGIC-VARS: Hs A B Ls X Y ;
+SYMBOLS: red blue green white yellow ;
+SYMBOLS: english swede dane norwegian german ;
+SYMBOLS: dog cat birds horse zebra ;
+SYMBOLS: tea coffee beer milk water ;
+SYMBOLS: pall-mall dunhill blue-master prince blend ;
+TUPLE: house color nationality drink smoke pet ;
+
+{ houseso Hs X Y } {
+ { (=) Hs ! #1
+ L{ T{ house f __ norwegian __ __ __ } ! #10
+ T{ house f blue __ __ __ __ } ! #15
+ T{ house f __ __ milk __ __ } ! #9
+ __
+ __ } }
+ { membero T{ house f red english __ __ __ } Hs } ! #2
+ { membero T{ house f __ swede __ __ dog } Hs } ! #3
+ { membero T{ house f __ dane tea __ __ } Hs } ! #4
+ { lefto T{ house f green __ __ __ __ } T{ house f white __ __ __ __ } Hs } ! #5
+ { membero T{ house f green __ coffee __ __ } Hs } ! #6
+ { membero T{ house f __ __ __ pall-mall birds } Hs } ! #7
+ { membero T{ house f yellow __ __ dunhill __ } Hs } ! #8
+ { nexto T{ house f __ __ __ blend __ } T{ house f __ __ __ __ cat } Hs } ! #11
+ { nexto T{ house f __ __ __ dunhill __ } T{ house f __ __ __ __ horse } Hs } ! #12
+ { membero T{ house f __ __ beer blue-master __ } Hs } ! #13
+ { membero T{ house f __ german __ prince __ } Hs } ! #14
+ { nexto T{ house f __ __ water __ __ } T{ house f __ __ __ blend __ } Hs } ! #16
+ { membero T{ house f __ X water __ __ } Hs }
+ { membero T{ house f __ Y __ __ zebra } Hs }
+} rule
+
+{ nexto A B Ls } {
+ { appendo __ L{ A B . __ } Ls } ;;
+ { appendo __ L{ B A . __ } Ls }
+} rule
+
+{ lefto A B Ls } { appendo __ L{ A B . __ } Ls } rule
+
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test factlog lists factlog.examples.zebra2 ;
+IN: factlog.examples.zebra2.tests
+
+{
+ {
+ H{
+ {
+ Hs
+ L{
+ T{ house
+ { color yellow }
+ { nationality norwegian }
+ { drink water }
+ { smoke dunhill }
+ { pet cat }
+ }
+ T{ house
+ { color blue }
+ { nationality dane }
+ { drink tea }
+ { smoke blend }
+ { pet horse }
+ }
+ T{ house
+ { color red }
+ { nationality english }
+ { drink milk }
+ { smoke pall-mall }
+ { pet birds }
+ }
+ T{ house
+ { color green }
+ { nationality german }
+ { drink coffee }
+ { smoke prince }
+ { pet zebra }
+ }
+ T{ house
+ { color white }
+ { nationality swede }
+ { drink beer }
+ { smoke blue-master }
+ { pet dog }
+ }
+ }
+ }
+ { X norwegian }
+ { Y german }
+ }
+ }
+}
+[ { houseso Hs X Y } query ] unit-test
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: factlog lists ;
+IN: factlog.examples.zebra2
+
+LOGIC-PREDS: existso righto middleo firsto nexto
+ houseso zebrao watero ;
+LOGIC-VARS: A B L R Hs X Y ;
+SYMBOLS: red blue green white yellow ;
+SYMBOLS: english swede dane german norwegian ;
+SYMBOLS: dog birds zebra cat horse ;
+SYMBOLS: coffee tea milk beer water ;
+SYMBOLS: prince dunhill pall-mall blend blue-master ;
+
+TUPLE: house color nationality drink smoke pet ;
+{
+ { existso A L{ A __ __ __ __ } }
+ { existso A L{ __ A __ __ __ } }
+ { existso A L{ __ __ A __ __ } }
+ { existso A L{ __ __ __ A __ } }
+ { existso A L{ __ __ __ __ A } }
+
+ { righto R L L{ L R __ __ __ } }
+ { righto R L L{ __ L R __ __ } }
+ { righto R L L{ __ __ L R __ } }
+ { righto R L L{ __ __ __ L R } }
+
+ { middleo A L{ __ __ A __ __ } }
+
+ { firsto A L{ A __ __ __ __ } }
+
+ { nexto A B L{ B A __ __ __ } }
+ { nexto A B L{ __ B A __ __ } }
+ { nexto A B L{ __ __ B A __ } }
+ { nexto A B L{ __ __ __ B A } }
+ { nexto A B L{ A B __ __ __ } }
+ { nexto A B L{ __ A B __ __ } }
+ { nexto A B L{ __ __ A B __ } }
+ { nexto A B L{ __ __ __ A B } }
+} facts
+
+{ houseso Hs X Y } {
+ { existso T{ house f red english __ __ __ } Hs } ! #2
+ { existso T{ house f __ swede __ __ dog } Hs } ! #3
+ { existso T{ house f __ dane tea __ __ } Hs } ! #4
+ { righto T{ house f white __ __ __ __ } T{ house f green __ __ __ __ } Hs } ! #5
+ { existso T{ house f green __ coffee __ __ } Hs } ! #6
+ { existso T{ house f __ __ __ pall-mall birds } Hs } ! #7
+ { existso T{ house f yellow __ __ dunhill __ } Hs } ! #8
+ { middleo T{ house f __ __ milk __ __ } Hs } ! #9
+ { firsto T{ house f __ norwegian __ __ __ } Hs } ! #10
+ { nexto T{ house f __ __ __ blend __ } T{ house f __ __ __ __ cat } Hs } ! #11
+ { nexto T{ house f __ __ __ dunhill __ } T{ house f __ __ __ __ horse } Hs } ! #12
+ { existso T{ house f __ __ beer blue-master __ } Hs } ! #13
+ { existso T{ house f __ german __ prince __ } Hs } ! #14
+ { nexto T{ house f __ norwegian __ __ __ } T{ house f blue __ __ __ __ } Hs } ! #15
+ { nexto T{ house f __ __ water __ __ } T{ house f __ __ __ blend __ } Hs } ! #16
+ { existso T{ house f __ X water __ __ } Hs }
+ { existso T{ house f __ Y __ __ zebra } Hs }
+} rule
+
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax kernel quotations sequences
+ prettyprint assocs math make lists urls factlog.private ;
+IN: factlog
+
+HELP: !!
+{ $var-description "The cut operator.\nUse the cut operator to suppress backtracking." }
+{ $examples
+ "In the following example, it is used to define that cats generally eat mice, but Tom does not."
+ { $example
+ "USING: factlog prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: is-ao consumeso ;"
+ "LOGIC-VARS: X Y ;"
+ "SYMBOLS: Tom Jerry Nibbles"
+ " mouse cat milk cheese fresh-milk Emmentaler ;"
+ ""
+ "{"
+ " { is-ao Tom cat }"
+ " { is-ao Jerry mouse }"
+ " { is-ao Nibbles mouse }"
+ " { is-ao fresh-milk milk }"
+ " { is-ao Emmentaler cheese }"
+ "} facts"
+ ""
+ "{ consumeso X milk } {"
+ " { is-ao X mouse } ;;"
+ " { is-ao X cat }"
+ "} rule"
+ ""
+ "{ consumeso X cheese } { is-ao X mouse } rule"
+ "{ consumeso Tom mouse } { !! f } rule"
+ "{ consumeso X mouse } { is-ao X cat } rule"
+ ""
+ "{ { consumeso Tom X } { is-ao Y X } } query ."
+ "{ H{ { X milk } { Y fresh-milk } } }"
+ }
+} ;
+
+HELP: (<)
+{ $var-description "A logic predicate. It takes two arguments. It is true if both arguments are evaluated numerically and the first argument is less than the second, otherwise, it is false." }
+{ $syntax "{ (<) X Y }" }
+{ $see-also (>) (>=) (==) (=<) } ;
+
+HELP: (=)
+{ $var-description "A logic predicate. It unifies two arguments." }
+{ $syntax "{ (=) X Y }" }
+{ $see-also (\=) is } ;
+
+HELP: (=<)
+{ $var-description "A logic predicate. It takes two arguments. It is true if both arguments are evaluated numerically and the first argument equals or is less than the second, otherwise, it is false." }
+{ $syntax "{ (=<) X Y }" }
+{ $see-also (>) (>=) (==) (<) } ;
+
+HELP: (==)
+{ $var-description "A logic predicate. It tests for equality of two arguments. Evaluating two arguments, true if they are the same, false if they are different." }
+{ $syntax "{ (==) X Y }" }
+{ $see-also (>) (>=) (=<) (<) =:= =\= } ;
+
+HELP: (>)
+{ $var-description "A logic predicate. It is true if both arguments are evaluated numerically and the first argument is greater than the second, otherwise, it is false." }
+{ $syntax "{ (>) X Y }" }
+{ $see-also (>=) (==) (=<) (<) } ;
+
+HELP: (>=)
+{ $var-description "A logic predicate. It is true if both arguments are evaluated numerically and the first argument equals or is greater than the second, otherwise, it is false." }
+{ $syntax "{ (>=) X Y }" }
+{ $see-also (>) (==) (=<) (<) } ;
+
+HELP: (\=)
+{ $var-description "A logic predicate. It will be true when such a unification fails. Note that " { $snippet "(\\=)" } " does not actually do the unification." }
+{ $syntax "{ (\\=) X Y }" }
+{ $see-also (=) } ;
+
+HELP: (\==)
+{ $var-description "A logic predicate. It tests for inequality of two arguments. Evaluating two arguments, true if they are different, false if they are the same." }
+{ $syntax "{ (\\==) X Y }" }
+;
+
+HELP: ;;
+{ $var-description "Is used to represent disjunction. The code below it has the same meaning as the code below it.
+"
+{ $code
+ "Gh { Gb1 Gb2 Gb3 ;; Gb4 Gb5 ;; Gb6 } rule" }
+""
+{ $code
+ "Gh { Gb1 Gb2 Gb3 } rule"
+ "Gh { Gb4 Gb5 } rule:
+Gh { Gb6 } rule" }
+} ;
+
+HELP: =:=
+{ $values
+ { "quot" quotation }
+ { "goal" logic-goal }
+}
+{ $description "The quotations takes an environment and returns two values. " { $snippet "=:=" } " returns the internal representation of the goal which returns t if values returned by the quotation are same numbers.\n" { $snippet "=:=" } " is intended to be used in a quotation. If there is a quotation in the definition of rule, factlog uses the internal definition of the goal obtained by calling it." }
+{ $see-also (==) =\= } ;
+
+HELP: =\=
+{ $values
+ { "quot" quotation }
+ { "goal" logic-goal }
+}
+{ $description "The quotations takes an environment and returns two values. " { $snippet "=\\=" } " returns the internal representation of the goal which returns t if values returned by the quotation are numbers and are not same.\n" { $snippet "=\\=" } " is intended to be used in a quotation. If there is a quotation in the definition of rule, factlog uses the internal definition of the goal obtained by calling it." }
+{ $see-also (==) =:= } ;
+
+HELP: LOGIC-PREDS:
+{ $description "Creates a new logic predicate for every token until the ;." }
+{ $syntax "LOGIC-PREDS: preds... ;" }
+{ $examples
+ { $code
+ "USE: factlog"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: cato mouseo ;"
+ "SYMBOLS: Tom Jerry ;"
+ ""
+ "{ cato Tom } fact"
+ "{ mouseo Jerry } fact"
+ }
+} ;
+
+HELP: LOGIC-VARS:
+{ $description "Creates a new logic variable for every token until the ;." }
+{ $syntax "LOGIC-VARS: vars... ;" }
+{ $examples
+ { $example
+ "USING: factlog prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: mouseo ;"
+ "LOGIC-VARS: X ;"
+ "SYMBOL: Jerry"
+ "{ mouseo Jerry } fact"
+ "{ mouseo X } query ."
+ "{ H{ { X Jerry } } }"
+ }
+} ;
+
+HELP: %!
+{ $description "A multiline comment. Despite being a Prolog single-line comment, " { $link % } " is already well-known in Factor, so this variant is given instead." }
+{ $syntax "%! comment !%" }
+{ $examples
+ { $example
+ "USE: factlog"
+ "%! I think that I shall never see"
+ " A proof lovely as a factlog. !%"
+ ""
+ }
+} ;
+
+HELP: \+
+{ $var-description "Express negation. \\+ acts on the goal immediately following it.\n" }
+{ $examples
+ { $example
+ "USING: factlog prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: cato mouseo creatureo ;"
+ "LOGIC-VARS: X Y ;"
+ "SYMBOLS: Tom Jerry Nibbles ;"
+ ""
+ "{ cato Tom } fact"
+ "{ mouseo Jerry } fact"
+ "{ mouseo Nibbles } fact"
+ "{ creatureo Y } {
+ { cato Y } ;; { mouseo Y }
+} rule"
+ ""
+ "LOGIC-PREDS: likes-cheeseo dislikes-cheeseo ;"
+ ""
+ "{ likes-cheeseo X } { mouseo X } rule"
+ "{ dislikes-cheeseo Y } {
+ { creatureo Y }
+ \\+ { likes-cheeseo Y }
+ } rule"
+ "{ dislikes-cheeseo Jerry } query ."
+ "{ dislikes-cheeseo Tom } query ."
+ "f\nt"
+ }
+} ;
+
+HELP: __
+{ $var-description "An anonymous logic variable.\nUse in place of a regular logic variable when you do not need its name and value." }
+{ $examples
+ { $example
+ "USING: factlog prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "SYMBOLS: Tom Jerry Nibbles ;"
+ "TUPLE: house living dining kitchen in-the-wall ;"
+ "LOGIC-PREDS: houseo ;"
+ "LOGIC-VARS: X ;"
+
+ ""
+ "{ houseo T{ house"
+ " { living Tom }"
+ " { dining f }"
+ " { kitchen Nibbles }"
+ " { in-the-wall Jerry }"
+ " }"
+ "} fact"
+ ""
+ "{ houseo T{ house"
+ " { living __ }"
+ " { dining __ }"
+ " { kitchen X }"
+ " { in-the-wall __ }"
+ " }"
+ "} query ."
+ "{ H{ { X Nibbles } } }"
+ }
+} ;
+
+HELP: appendo
+{ $var-description "A logic predicate. Concatenate two lists." }
+{ $syntax "{ appendo List1 List2 List1+List2 }" }
+{ $examples
+ { $example
+ "USING: factlog lists prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "SYMBOLS: Tom Jerry Nibbles ;"
+ "LOGIC-VARS: X Y ;"
+ ""
+ "{ appendo L{ Tom } L{ Jerry Nibbles } X } query ."
+ "{ appendo L{ Tom } L{ Jerry Nibbles } L{ Jerry Nibbles Tom } } query ."
+ "{ appendo X Y L{ Tom Jerry Nibbles } } query ."
+ "{ H{ { X L{ Tom Jerry Nibbles } } } }\nf\n{\n H{ { X L{ } } { Y L{ Tom Jerry Nibbles } } }\n H{ { X L{ Tom } } { Y L{ Jerry Nibbles } } }\n H{ { X L{ Tom Jerry } } { Y L{ Nibbles } } }\n H{ { X L{ Tom Jerry Nibbles } } { Y L{ } } }\n}"
+ }
+} ;
+
+HELP: callback
+{ $values
+ { "head" array } { "quot" quotation }
+}
+{ $description "Set the quotation to be called. Such quotations take an environment which holds the binding of logic variables, and returns t or " { $link f } " as a result of execution. To retrieve the values of logic variables in the environment, use " { $link of } " or " { $link at } "." }
+{ $examples
+ { $code
+ "LOGIC-PREDS: N_>_0 ;"
+ "{ N_>_0 N } [ N of 0 > ] callback"
+ }
+}
+{ $see-also callbacks } ;
+
+HELP: callbacks
+{ $values
+ { "defs" array }
+}
+{ $description "To collectively register a plurality of " { $link callback } "s." }
+{ $examples
+ { $code "LOGIC-PREDS: N_>_0 N2_is_N_-_1 F_is_F2_*_N ;
+{
+ { { N_>_0 N } [ N of 0 > ] }
+ { N2_is_N_-_1 N2 N } [ dup N of 1 - N2 unify ] }
+ { F_is_F2_*_N F F2 N } [ dup [ F2 of ] [ N of ] bi * F unify ] }
+} callbacks" }
+}
+{ $see-also callback } ;
+
+HELP: clear-pred
+{ $values
+ { "pred" "a logic predicate" }
+}
+{ $description "Clears all the definition information for the given logic predicate." }
+{ $examples
+ { $example
+ "USING: factlog prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: mouseo ;"
+ "SYMBOLS: Jerry Nibbles ;"
+ "LOGIC-VARS: X ;"
+ ""
+ "{ mouseo Jerry } fact"
+ "{ mouseo Nibbles } fact"
+ ""
+ "{ mouseo X } query ."
+ "mouseo clear-pred"
+ "{ mouseo X } query ."
+ "{ H{ { X Jerry } } H{ { X Nibbles } } }\nf"
+ }
+}
+{ $see-also retract retract-all } ;
+
+HELP: fact
+{ $values
+ { "head" "an array representing a goal" }
+}
+{ $description "Registers the fact to the end of the logic predicate that is in the head." }
+{ $examples
+ { $code
+ "USE: factlog"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: cato mouseo ;"
+ "SYMBOLS: Tom Jerry ;"
+ "{ cato Tom } fact"
+ "{ mouseo Jerry } fact"
+ }
+}
+{ $see-also fact* facts } ;
+
+HELP: fact*
+{ $values
+ { "head" "an array representing a goal" }
+}
+{ $description "Registers the fact to the beginning of the logic predicate that is in the head." }
+{ $see-also fact facts } ;
+
+HELP: facts
+{ $values
+ { "defs" array }
+}
+{ $description "Registers these facts to the end of the logic predicate that is in the head." }
+{ $examples
+ { $code
+ "USE: factlog"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: cato mouseo ;"
+ ""
+ "{ { cato Tom } { mouseo Jerry } } facts"
+ }
+}
+{ $see-also fact fact* } ;
+
+HELP: failo
+{ $var-description "A built-in logic predicate. { " { $snippet "failo" } " } is a goal that is always " { $link f } "." }
+{ $syntax "{ failo }" }
+{ $see-also trueo } ;
+
+HELP: is
+{ $values
+ { "quot" quotation } { "dist" "a logic predicate" }
+ { "goal" logic-goal }
+}
+{ $description "Takes a quotation and a logic variable to be unified. Each of the two quotations takes an environment and returns a value. " { $snippet "is" } " returns the internal representation of the goal.\n" { $snippet "is" } " is intended to be used in a quotation. If there is a quotation in the definition of rule, factlog uses the internal definition of the goal obtained by calling it." } ;
+
+HELP: invoke
+{ $values
+ { "quot" quotation }
+ { "goal" logic-goal }
+}
+{ $description "Creates a goal which uses the values of obtained logic variables. It can be used to add new rules to or drop rules from the database while a " { $link query } " is running.\nThe argument " { $snippet "quot" } " must not return any values, the created goal always return " { $link t } ".\n" { $snippet "invoke" } " is intended to be used in a quotation. If there is a quotation in the definition of rule, factlog uses the internal definition of the goal obtained by calling it." }
+{ $examples
+ "In this example, the calculated values are memorized to eliminate recalculation."
+ { $example
+ "USING: factlog kernel lists assocs locals math prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: fibo ;"
+ "LOGIC-VARS: F F1 F2 N N1 N2 ;"
+ ""
+ "{ fibo 1 1 } fact"
+ "{ fibo 2 1 } fact"
+ "{ fibo N F } {"
+ " { (>) N 2 }"
+ " [ [ N of 1 - ] N1 is ] { fibo N1 F1 }"
+ " [ [ N of 2 - ] N2 is ] { fibo N2 F2 }"
+ " [ [ [ F1 of ] [ F2 of ] bi + ] F is ]"
+ " ["
+ " ["
+ " [ N of ] [ F of ] bi"
+ " [let :> ( nv fv ) { fibo nv fv } !! rule* ]"
+ " ] invoke ]"
+ "} rule"
+ ""
+ "{ fibo 10 F } query ."
+ "{ H{ { F 55 } } }"
+ }
+}
+{ $see-also invoke* } ;
+
+HELP: invoke*
+{ $values
+ { "quot" quotation }
+ { "goal" logic-goal }
+}
+{ $description "Creates a goal which uses the values of obtained logic variables. The difference with " { $link invoke } " is that " { $snippet "quot" } " returns " { $link t } " or " { $link f } ", and the created goal returns it.\n" { $snippet "invoke*" } " is intended to be used in a quotation. If there is a quotation in the definition of rule, factlog uses the internal definition of the goal obtained by calling it." }
+{ $see-also invoke } ;
+
+HELP: lengtho
+{ $var-description "A logic predicate. Instantiate the length of the list." }
+{ $syntax "{ lengtho List X }" }
+{ $examples
+ { $example
+ "USING: factlog lists prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "SYMBOLS: Tom Jerry Nibbles ;"
+ "LOGIC-VARS: X ;"
+ ""
+ "{ lengtho L{ Tom Jerry Nibbles } 3 } query ."
+ "{ lengtho L{ Tom Jerry Nibbles } X } query ."
+ "t\n{ H{ { X 3 } } }"
+ }
+} ;
+
+HELP: listo
+{ $var-description "A logic predicate. Takes a single argument and checks to see if it is a list." }
+{ $syntax "{ listo X }" }
+{ $examples
+ { $example
+ "USING: factlog lists prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "SYMBOLS: Tom Jerry Nibbles ;"
+ ""
+ "{ listo L{ Jerry Nibbles } } query ."
+ "{ listo Tom } query ."
+ "t\nf"
+ }
+} ;
+
+HELP: membero
+{ $var-description "A logic predicate for the relationship an element is in a list." }
+{ $syntax "{ membero X List }" }
+{ $examples
+ { $example
+ "USING: factlog lists prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "SYMBOLS: Tom Jerry Nibbles Spike ;"
+ ""
+ "{ membero Jerry L{ Tom Jerry Nibbles } } query ."
+ "{ membero Spike L{ Tom Jerry Nibbles } } query ."
+ "t\nf"
+ }
+} ;
+
+HELP: nlo
+{ $var-description "A logic predicate. Print line breaks." }
+{ $syntax "{ nlo }" }
+{ $see-also writeo writenlo } ;
+
+HELP: nonvaro
+{ $var-description "A logic predicate. "{ $snippet "nonvaro" } " takes a single argument and is true if its argument is not a logic variable or is a concrete logic variable." }
+{ $syntax "{ nonvaro X }" }
+{ $see-also varo } ;
+
+HELP: notrace
+{ $description "Stop tracing." }
+{ $see-also trace } ;
+
+HELP: query
+{ $values
+ { "goal-def/defs" "a goal def or an array of goal defs" }
+ { "bindings-array/success?" "anser" }
+}
+{ $description
+ "Inquire about the order of goals. The general form of a query is:
+
+ { G1 G2 ... Gn } query
+
+This G1, G2, ... Gn is a conjunction. When all of them are satisfied, it becomes " { $link t } ".
+
+If there is only one goal, you can use its abbreviation.
+
+ G1 query
+
+When you query with logic variable(s), you will get the answer for the logic variable(s). For such queries, an array of hashtables with logic variables as keys is returned.
+"
+}
+{ $examples
+ { $example
+ "USING: factlog prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: cato mouseo creatureo ;"
+ "LOGIC-VARS: X Y ;"
+ "SYMBOLS: Tom Jerry Nibbles ;"
+ ""
+ "{ cato Tom } fact"
+ "{ mouseo Jerry } fact"
+ "{ mouseo Nibbles } fact"
+ ""
+ "{ cato Tom } query ."
+ "{ { cato Tom } { cato Jerry } } query ."
+ "{ mouseo X } query ."
+ "t\nf\n{ H{ { X Jerry } } H{ { X Nibbles } } }"
+ }
+}
+{ $see-also query-n } ;
+
+HELP: query-n
+{ $values
+ { "goal-def/defs" "a goal def or an array of goal defs" } { "n/f" "the highest number of responses" }
+ { "bindings-array/success?" "anser" }
+}
+{ $description "The version of " { $link query } " that limits the number of responses. Specify a number greater than or equal to 1.
+If " { $link f } " is given instead of a number as " { $snippet "n/f" } ", there is no limit to the number of answers. That is, the behavior is the same as " { $link query } "." }
+{ $see-also query } ;
+
+HELP: retract
+{ $values
+ { "head-def" "a logic predicate" }
+}
+{ $description "Removes the first definition that matches the given head information." }
+{ $examples
+ { $example
+ "USING: factlog prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: mouseo ;"
+ "SYMBOLS: Jerry Nibbles ;"
+ ""
+ "{ mouseo Jerry } fact"
+ "{ mouseo Nibbles } fact"
+ ""
+ "{ mouseo X } query ."
+ "{ mouseo Jerry } retract"
+ "{ mouseo X } query ."
+ "{ H{ { X Jerry } } H{ { X Nibbles } } }\n{ H{ { X Nibbles } } }"
+ }
+}
+{ $see-also retract-all clear-pred } ;
+
+HELP: retract-all
+{ $values
+ { "head-def" "a logic predicate" }
+}
+{ $description "Removes all definitions that match a given head goal definition." }
+{ $examples
+ { $example
+ "USING: factlog prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: mouseo ;"
+ "SYMBOLS: Jerry Nibbles ;"
+ ""
+ "{ mouseo Jerry } fact"
+ "{ mouseo Nibbles } fact"
+ ""
+ "{ mouseo X } query ."
+ "{ mouseo __ } retract-all"
+ "{ mouseo X } query ."
+ "{ H{ { X Jerry } } H{ { X Nibbles } } }\nf"
+ }
+}
+{ $see-also retract clear-pred } ;
+
+HELP: rule
+{ $values
+ { "head" "an array representing a goal" } { "body" "an array of goals or a goal" }
+}
+{ $description "Registers the rule to the end of the logic predicate that is in the head.
+The general form of rule is:
+
+ Gh { Gb1 Gb2 ... Gbn } rule
+
+This means Gh when all goals of Gb1, Gb2, ..., Gbn are met. This Gb1 Gb2 ... Gbn is a conjunction.
+If the body array contains only one goal definition, you can write it instead of the body array. That is, they are equivalent.
+
+ Gh { Gb } rule
+ Gh Gb rule" }
+{ $examples
+ { $example
+ "USING: factlog prettyprint ;"
+ "IN: scratchpad"
+ ""
+ "LOGIC-PREDS: mouseo youngo young-mouseo ;"
+ "SYMBOLS: Jerry Nibbles ;"
+ ""
+ "{ mouseo Jerry } fact"
+ "{ mouseo Nibbles } fact"
+ "{ youngo Nibbles } fact"
+ ""
+ "{ young-mouseo X } {"
+ " { mouseo X }"
+ " { youngo X }"
+ "} rule"
+ ""
+ "{ young-mouseo X } query ."
+ "{ H{ { X Nibbles } } }"
+ }
+}
+{ $see-also rule* rules } ;
+
+HELP: rule*
+{ $values
+ { "head" "an array representing a goal" } { "body" "an array of goals or a goal" }
+}
+{ $description "Registers the rule to the beginnung of the logic predicate that is in the head." }
+{ $see-also rule rules } ;
+
+HELP: rules
+{ $values
+ { "defs" "an array of rules" }
+}
+{ $description "Registers these rules to the end of the logic predicate that is in these heads." }
+{ $examples
+ { $code
+ "LOGIC-PREDS: is-ao consumeso ;"
+ "SYMBOLS: Tom Jerry Nibbles ;"
+ "SYMBOLS: mouse cat milk cheese fresh-milk Emmentaler ;"
+ ""
+ "{"
+ " { is-ao Tom cat }"
+ " { is-ao Jerry mouse }"
+ " { is-ao Nibbles mouse }"
+ " { is-ao fresh-milk milk }"
+ " { is-ao Emmentaler cheese }"
+ "} facts"
+ ""
+ "{"
+ " {"
+ " { consumeso X milk } {"
+ " { is-ao X mouse } ;;"
+ " { is-ao X cat }"
+ " }"
+ " }"
+ " { { consumeso X cheese } { is-ao X mouse } }"
+ " { { consumeso X mouse } { is-ao X cat } }"
+ "} rules"
+ }
+}
+{ $see-also rule rule* } ;
+
+HELP: trace
+{ $description "Start tracing." }
+{ $see-also notrace } ;
+
+HELP: trueo
+{ $var-description "A logic predicate. { " { $snippet "trueo" } " } is a goal that is always " { $link t } "." }
+{ $syntax "{ trueo }" }
+{ $see-also failo } ;
+
+HELP: unify
+{ $values
+ { "cb-env" callback-env } { "x" object } { "y" object }
+ { "success?" boolean }
+}
+{ $description "Unifies the two following the environment in that environment." } ;
+
+HELP: varo
+{ $var-description "A logic predicate. " { $snippet "varo" } " takes a argument and is true if it is a logic variable with no value." }
+{ $syntax "{ varo X }" }
+{ $see-also nonvaro } ;
+
+HELP: writenlo
+{ $var-description "A logic predicate. print a single sequence or string and return a new line." }
+{ $syntax "{ writenlo X }" }
+{ $see-also writeo nlo } ;
+
+HELP: writeo
+{ $var-description "A logic predicate. print a single sequence or string of characters." }
+{ $syntax "{ writeo X }" }
+{ $see-also writenlo nlo } ;
+
+ARTICLE: "factlog" "How to use factlog"
+{ $vocab-link "factlog" }
+" is an embedded language that runs on "{ $url "https://github.com/factor/factor" "Factor" } " with the capabilities of a subset of Prolog." $nl
+"It is an extended port from tiny_prolog and its descendants, " { $url "https://github.com/preston/ruby-prolog" "ruby-prolog" } "." $nl
+{ $code
+"USE: factlog
+
+LOGIC-PREDS: cato mouseo creatureo ;
+LOGIC-VARS: X Y ;
+SYMBOLS: Tom Jerry Nibbles ;"
+} $nl
+"In factlog, words that represent relationships are called " { $strong "logic predicates" } ". Use " { $link \ LOGIC-PREDS: } " to declare the predicates you want to use. " { $strong "Logic variables" } " are used to represent relationships. use " { $link \ LOGIC-VARS: } " to declare the logic variables you want to use." $nl
+"In the above code, logic predicates end with the character 'o', which is a convention borrowed from miniKanren and so on, and means relation. This is not necessary, but it is useful for reducing conflicts with the words of, the parent language, Factor. We really want to write them as: " { $snippet "cat°" } ", " { $snippet "mouse°" } " and " { $snippet "creature°" } ", but we use 'o' because it's easy to type." $nl
+{ $strong "Goals" } " are questions that factlog tries to meet to be true. To represent a goal, write an array with a logic predicate followed by zero or more arguments. factlog converts such definitions to internal representations." $nl
+{ $code "{ LOGIC-PREDICATE ARG1 ARG2 ... }" }
+{ $code "{ LOGIC-PREDICATE }" } $nl
+"We will write factlog programs using these goals." $nl
+{ $code
+"{ cato Tom } fact
+{ mouseo Jerry } fact
+{ mouseo Nibbles } fact"
+} $nl
+"The above code means that Tom is a cat and Jerry and Nibbles are mice. Use " { $link fact } " to describe the " { $strong "facts" } "." $nl
+{ $unchecked-example
+"{ cato Tom } query ."
+"t"
+} $nl
+"The above code asks, \"Is Tom a cat?\". We said,\"Tom is a cat.\", so the answer is " { $link t } ". The general form of a query is:" $nl
+{ $code "{ G1 G2 ... Gn } query" } $nl
+"The parentheses are omitted because there was only one goal to be satisfied earlier, but here is an example of two goals:" $nl
+{ $unchecked-example
+"{ { cato Tom } { cato Jerry } } query ."
+"f"
+} $nl
+"Tom is a cat, but Jerry is not declared a cat, so " { $link f } " is returned in response to this query." $nl
+"If you query with logic variable(s), you will get the answer for the logic variable(s). For such queries, an array of hashtables with logic variables as keys is returned." $nl
+{ $unchecked-example
+"{ mouseo X } query ."
+"{ H{ { X Jerry } } H{ { X Nibbles } } }"
+} $nl
+"The following code shows that if something is a cat, it's a creature. Use " { $link rule } " to write " { $strong "rules" } "." $nl
+{ $code
+ "{ creatureo X } { cato X } rule"
+} $nl
+"According to the rules above, \"Tom is a creature.\" is answered to the following questions:" $nl
+{ $unchecked-example
+"{ creatureo Y } query ."
+"{ H{ { Y Tom } } }"
+} $nl
+"The general form of " { $link rule } " is:" $nl
+{ $code "Gh { Gb1 Gb2 ... Gbn } rule" } $nl
+"This means " { $snippet "Gh" } " when all goals of " { $snippet "Gb1" } ", " { $snippet "Gb2" } ", ..., " { $snippet "Gbn" } " are met. This " { $snippet "Gb1 Gb2 ... Gbn" } " is a " { $strong "conjunction" } "." $nl
+{ $unchecked-example
+"LOGIC-PREDS: youngo young-mouseo ;
+
+{ youngo Nibbles } fact
+
+{ young-mouseo X } {
+ { mouseo X }
+ { youngo X }
+} rule
+
+{ young-mouseo X } query ."
+"{ H{ { X Nibbles } } }"
+} $nl
+"This " { $snippet "Gh" } " is called " { $strong "head" } " and the " { $snippet "{ Gb 1Gb 2... Gbn }" } " is called " { $strong "body" } "." $nl
+"Facts are rules where its body is an empty array. So, the form of " { $link fact } " is:" $nl
+{ $code "Gh fact" } $nl
+"Let's describe that mice are also creatures." $nl
+{ $unchecked-example
+"{ creatureo X } { mouseo X } rule
+
+{ creatureo X } query ."
+"{ H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } } }"
+} $nl
+"To tell the truth, we were able to describe at once that cats and mice were creatures by doing the following." $nl
+{ $code
+"LOGIC-PREDS: creatureo ;
+
+{ creatureo Y } {
+ { cato Y } ;; { mouseo Y }
+} rule"
+} $nl
+{ $link ;; } " is used to represent " { $strong "disjunction" } ". The following two forms are equivalent:" $nl
+{ $code "Gh { Gb1 Gb2 Gb3 ;; Gb4 Gb5 ;; Gb6 } rule" }
+$nl
+{ $code
+ "Gh { Gb1 Gb2 Gb3 } rule"
+ "Gh { Gb4 Gb5 } rule"
+ "Gh { Gb6 } rule"
+} $nl
+"factlog actually converts the disjunction in that way. You may need to be careful about that when deleting definitions that you registered using " { $link rule } ", etc." $nl
+"You can use " { $link query-n } " to limit the number of answers to a query. Specify a number greater than or equal to 1." $nl
+{ $unchecked-example
+"{ creatureo Y } 2 query-n ."
+"{ H{ { Y Tom } } H{ { Y Jerry } } }"
+} $nl
+"Use " { $link \+ } " to express " { $strong "negation" } ". " { $link \+ } " acts on the goal immediately following it." $nl
+{ $unchecked-example
+"LOGIC-PREDS: likes-cheeseo dislikes-cheeseo ;
+
+{ likes-cheeseo X } { mouseo X } rule
+
+{ dislikes-cheeseo Y } {
+ { creatureo Y }
+ \\+ { likes-cheeseo Y }
+} rule"
+"{ dislikes-cheeseo Jerry } query ."
+"{ dislikes-cheeseo Tom } query ."
+"f\nt"
+} $nl
+"Other creatures might also like cheese..." $nl
+"You can also use sequences, lists, and tuples as goal definition arguments." $nl
+"The syntax of list descriptions allows you to describe \"head\" and \"tail\" of a list." $nl
+{ $code "L{ HEAD . TAIL }" }
+{ $code "L{ ITEM1 ITEM2 ITEM3 . OTHERS }" } $nl
+"You can also write a quotation that returns an argument as a goal definition argument." $nl
+{ $code "[ Tom Jerry Nibbles L{ } cons cons cons ]" } $nl
+"When written as an argument to a goal definition, the following lines have the same meaning as above:" $nl
+{ $code "L{ Tom Jerry Nibbles }" }
+{ $code "L{ Tom Jerry Nibbles . L{ } }" }
+{ $code "[ { Tom Jerry Nibbles } >list } ]" } $nl
+"Such quotations are called only once when converting the goal definitions to internal representations." $nl
+{ $link membero } " is a built-in logic predicate for the relationship an element is in a list." $nl
+{ $unchecked-example
+ "SYMBOL: Spike
+{ membero Jerry L{ Tom Jerry Nibbles } } query .
+{ membero Spike [ Tom Jerry Nibbles L{ } cons cons cons ] } query ."
+"t\nf"
+} $nl
+"Recently, they moved into a small house. The house has a living room, a dining room and a kitchen. Well, humans feel that way. Each of them seems to be in their favorite room." $nl
+{ $code
+"TUPLE: house living dining kitchen in-the-wall ;
+LOGIC-PREDS: houseo ;
+
+{ houseo T{ house { living Tom } { dining f } { kitchen Nibbles } { in-the-wall Jerry } } } fact"
+} $nl
+"Don't worry about not mentioning the bathroom." $nl
+"Let's ask who is in the kitchen." $nl
+{ $unchecked-example
+"{ houseo T{ house { living __ } { dining __ } { kitchen X } { in-the-wall __ } } } query ."
+"{ H{ { X Nibbles } } }"
+} $nl
+"These two consecutive underbars are called " { $strong "anonymous logic variables" } ". Use in place of a regular logic variable when you do not need its name and value." $nl
+"It seems to be meal time. What do they eat?" $nl
+{ $code
+"LOGIC-PREDS: is-ao consumeso ;
+SYMBOLS: mouse cat milk cheese fresh-milk Emmentaler ;
+
+{
+ { is-ao Tom cat }
+ { is-ao Jerry mouse }
+ { is-ao Nibbles mouse }
+ { is-ao fresh-milk milk }
+ { is-ao Emmentaler cheese }
+} facts
+
+{
+ {
+ { consumeso X milk } {
+ { is-ao X mouse } ;;
+ { is-ao X cat }
+ }
+ }
+ { { consumeso X cheese } { is-ao X mouse } }
+ { { consumeso X mouse } { is-ao X cat } }
+} rules"
+} $nl
+"Here, " { $link facts } " and " { $link rules } " are used. They can be used for successive facts or rules." $nl
+"Let's ask what Jerry consumes." $nl
+{ $unchecked-example
+"{ { consumeso Jerry X } { is-ao Y X } } query ."
+"{
+ H{ { X milk } { Y fresh-milk } }
+ H{ { X cheese } { Y Emmentaler } }
+}"
+} $nl
+"Well, what about Tom?" $nl
+{ $unchecked-example
+"{ { consumeso Tom X } { is-ao Y X } } query ."
+"{
+ H{ { X milk } { Y fresh-milk } }
+ H{ { X mouse } { Y Jerry } }
+ H{ { X mouse } { Y Nibbles } }
+}"
+} $nl
+"This is a problematical answer. We have to redefine " { $snippet "consumeso" } "." $nl
+{ $code
+"LOGIC-PREDS: consumeso ;
+
+{ consumeso X milk } {
+ { is-ao X mouse } ;;
+ { is-ao X cat }
+} rule
+
+{ consumeso X cheese } { is-ao X mouse } rule
+{ consumeso Tom mouse } { !! f } rule
+{ consumeso X mouse } { is-ao X cat } rule"
+} $nl
+"We wrote about Tom before about common cats. What two consecutive exclamation marks represent is called a " { $strong "cut" } " operator. Use the cut operator to suppress " { $strong "backtracking" } "." $nl
+"The next letter " { $link f } " is an abbreviation for goal { " { $link failo } " } using the built-in logic predicate " { $link failo } ". { " { $link failo } " } is a goal that is always " { $link f } ". Similarly, there is a goal { " { $link trueo } " } that is always " { $link t } ", and its abbreviation is " { $link t } "." $nl
+"By these actions, \"Tom consumes mice.\" becomes false and suppresses the examination of general eating habits of cats." $nl
+{ $unchecked-example
+"{ { consumeso Tom X } { is-ao Y X } } query ."
+"{ H{ { X milk } { Y fresh-milk } } }"
+} $nl
+"It's OK. Let's check a cat that is not Tom." $nl
+{ $unchecked-example
+"SYMBOL: a-cat
+{ is-ao a-cat cat } fact
+
+{ { consumeso a-cat X } { is-ao Y X } } query ."
+"{
+ H{ { X milk } { Y fresh-milk } }
+ H{ { X mouse } { Y Jerry } }
+ H{ { X mouse } { Y Nibbles } }
+}"
+} $nl
+"Jerry, watch out for the other cats." $nl
+"So far, we've seen how to define a logic predicate with " { $link fact } ", " { $link rule } ", " { $link facts } ", and " { $link rules } ". Each time you use those words for a logic predicate, information is added to it." $nl
+"You can clear these definitions with " { $link clear-pred } " for a logic predicate." $nl
+{ $unchecked-example
+"cato clear-pred
+mouseo clear-pred
+{ creatureo X } query ."
+"f"
+} $nl
+{ $link fact } " and " { $link rule } " add a new definition to the end of a logic predicate, while " { $link fact* } " and " { $link rule* } " add them first. The order of the information can affect the results of a query." $nl
+{ $unchecked-example
+"{ cato Tom } fact
+{ mouseo Jerry } fact
+{ mouseo Nibbles } fact*
+
+{ mouseo Y } query .
+
+{ creatureo Y } 2 query-n ."
+"{ H{ { Y Nibbles } } H{ { Y Jerry } } }\n{ H{ { Y Tom } } H{ { Y Nibbles } } }"
+} $nl
+"While " { $link clear-pred } " clears all the definition information for a given logic predicate, " { $link retract } " and " { $link retract-all } " provide selective clearing." $nl
+{ $link retract } " removes the first definition that matches the given head information." $nl
+{ $unchecked-example
+"{ mouseo Jerry } retract
+{ mouseo X } query ."
+"{ H{ { X Nibbles } } }"
+} $nl
+"On the other hand, " { $link retract-all } " removes all definitions that match a given head goal definition. Logic variables, including anonymous logic variables, can be used as goal definition arguments in " { $link retract } " and " { $link retract-all } ". A logic variable match any argument." $nl
+{ $unchecked-example
+"{ mouseo Jerry } fact
+{ mouseo X } query .
+
+{ mouseo __ } retract-all
+{ mouseo X } query ."
+"{ H{ { X Nibbles } } H{ { X Jerry } } }\nf"
+} $nl
+"let's have them come back." $nl
+{ $unchecked-example
+"{ { mouseo Jerry } { mouseo Nibbles } } facts
+{ creatureo X } query ."
+"{ H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } } }"
+} $nl
+"Logic predicates that take different numbers of arguments are treated separately. The previously used " { $snippet "cato" } " took one argument. Let's define " { $snippet "cato" } " that takes two arguments." $nl
+{ $unchecked-example
+"SYMBOLS: big small a-big-cat a-small-cat ;
+
+{ cato big a-big-cat } fact
+{ cato small a-small-cat } fact
+
+{ cato X } query .
+{ cato X Y } query .
+{ creatureo X } query ."
+"{ H{ { X Tom } } }\n{ H{ { X big } { Y a-big-cat } } H{ { X small } { Y a-small-cat } } }\n{ H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } }"
+} $nl
+"If you need to identify a logic predicate that has a different " { $strong "arity" } ", that is numbers of arguments, express it with a slash and an arity number. For example, " { $snippet "cato" } " with arity 1 is " { $snippet "cato/1" } ", " { $snippet "cato" } " with arity 2 is " { $snippet "cato/2" } ". But, note that factlog does not recognize these names." $nl
+{ $link clear-pred } " will clear all definitions of any arity. If you only want to remove the definition of a certain arity, you should use " { $link retract-all } " with logic variables." $nl
+{ $unchecked-example
+"{ cato __ __ } retract-all
+{ cato X Y } query ."
+"{ cato X } query ."
+"f\n{ H{ { X Tom } } }"
+} $nl
+"You can " { $strong "trace" } " factlog's execution. The word to do this is " { $link trace } "." $nl
+"The word to stop tracing is " { $link notrace } "." $nl
+"Here is a Prolog definition for the factorial predicate " { $snippet "factorial" } "." $nl
+"factorial(0, 1)." $nl
+"factorial(N, F) :- N > 0, N2 is N - 1, factorial(N2, F2), F is F2 * N." $nl
+"Let's think about how to do the same thing with factlog. It is mostly the following code, but is surrounded by backquotes where it has not been explained." $nl
+{ $code
+"USE: factlog
+
+LOGIC-PREDS: factorialo ;
+LOGIC-VARS: N N2 F F2 ;
+
+{ factorialo 0 1 } fact
+{ factorialo N F } {
+ `N > 0`
+ `N2 is N - 1`
+ { factorialo N2 F2 }
+ `F is F2 * N`
+} rule"
+} $nl
+"Within these backquotes are comparisons, calculations, and assignments (to be precise, " { $strong "unifications" } "). factlog has a mechanism to call Factor code to do these things. Here are some example." $nl
+{ $code "LOGIC-PREDS: N_>_0 N2_is_N_-_1 F_is_F2_*_N ;" }
+{ $code "{ N_>_0 N } [ N of 0 > ] callback" }
+{ $code "{ N2_is_N_-_1 N2 N } [ dup N of 1 - N2 unify ] callback" }
+{ $code "{ F_is_F2_*_N F F2 N } [ dup [ F2 of ] [ N of ] bi * F unify ] callback" } $nl
+"Use " { $link callback } " to set the quotation to be called. Such quotations take an " { $strong "environment" } " which holds the binding of logic variables, and returns " { $link t } " or " { $link f } " as a result of execution. To retrieve the values of logic variables in the environment, use " { $link of } " or " { $link at } "." $nl
+"The word " { $link unify } " unifies the two following the environment in that environment." $nl
+"Now we can rewrite the definition of factorialo to use them." $nl
+{ $code
+"USE: factlog
+
+LOGIC-PREDS: factorialo N_>_0 N2_is_N_-_1 F_is_F2_*_N ;
+LOGIC-VARS: N N2 F F2 ;
+
+{ factorialo 0 1 } fact
+{ factorialo N F } {
+ { N_>_0 N }
+ { N2_is_N_-_1 N2 N }
+ { factorialo N2 F2 }
+ { F_is_F2_*_N F F2 N }
+} rule
+
+{ N_>_0 N } [ N of 0 > ] callback
+
+{ N2_is_N_-_1 N2 N } [ dup N of 1 - N2 unify ] callback
+
+{ F_is_F2_*_N F F2 N } [ dup [ N of ] [ F2 of ] bi * F unify ] callback"
+} $nl
+"Let's try " { $snippet "factorialo" } "." $nl
+{ $unchecked-example
+"{ factorialo 0 F } query ."
+"{ H{ { F 1 } } }"
+}
+{ $unchecked-example
+"{ factorialo 1 F } query ."
+"{ H{ { F 1 } } }"
+}
+{ $unchecked-example
+"{ factorialo 10 F } query ."
+"{ H{ { F 3628800 } } }"
+} $nl
+"factlog has features that make it easier to meet the typical requirements shown here." $nl
+"There are the built-in logic predicates " { $link (<) } ", " { $link (>) } ", " { $link (>=) } ", and " { $link (=<) } " to compare numbers. There are also " { $link (==) } " and " { $link (\==) } " to test for equality and inequality of two arguments." $nl
+"The word " { $link is } " takes a quotation and a logic variable to be unified. The quotation takes an environment and returns a value. And " { $link is } " returns the internal representation of the goal. " { $link is } " is intended to be used in a quotation. If there is a quotation in the definition of " { $link rule } ", factlog uses the internal definition of the goal obtained by calling it." $nl
+"If you use these features to rewrite the definition of " { $snippet "factorialo" } ":" $nl
+{ $code
+"USE: factlog
+
+LOGIC-PREDS: factorialo ;
+LOGIC-VARS: N N2 F F2 ;
+
+{ factorialo 0 1 } fact
+{ factorialo N F } {
+ { (>) N 0 }
+ [ [ N of 1 - ] N2 is ]
+ { factorialo N2 F2 }
+ [ [ [ F2 of ] [ N of ] bi * ] F is ]
+} rule"
+} $nl
+"Use the built-in logic predicate " { $link (=) } " for unification that does not require processing with a quotation. " { $link (\=) } " will be true when such a unification fails. Note that " { $link (\=) } " does not actually do the unification." $nl
+{ $link varo } " takes a argument and is true if it is a logic variable with no value. On the other hand, " { $link nonvaro } " is true if its argument is not a logic variable or is a concrete logic variable." $nl
+"Now almost everything about factlog is explained."
+;
+
+ABOUT: "factlog"
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test factlog lists assocs math kernel namespaces
+accessors sequences
+factlog.examples.factorial
+factlog.examples.fib
+factlog.examples.fib2
+factlog.examples.hanoi
+factlog.examples.hanoi2
+factlog.examples.money
+factlog.examples.zebra
+factlog.examples.zebra2 ;
+
+IN: factlog.tests
+
+LOGIC-PREDS: cato mouseo creatureo ;
+LOGIC-VARS: X Y ;
+SYMBOLS: Tom Jerry Nibbles ;
+{ cato Tom } fact
+{ mouseo Jerry } fact
+{ mouseo Nibbles } fact
+
+{ t } [ { cato Tom } query ] unit-test
+{ f } [ { { cato Tom } { cato Jerry } } query ] unit-test
+{ { H{ { X Jerry } } H{ { X Nibbles } } } } [
+ { mouseo X } query
+] unit-test
+
+{ creatureo X } { cato X } rule
+
+{ { H{ { Y Tom } } } } [ { creatureo Y } query ] unit-test
+
+LOGIC-PREDS: youngo young-mouseo ;
+{ youngo Nibbles } fact
+{ young-mouseo X } {
+ { mouseo X }
+ { youngo X }
+} rule
+
+{ { H{ { X Nibbles } } } } [ { young-mouseo X } query ] unit-test
+
+{ creatureo X } { mouseo X } rule
+
+{ { H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } } } } [
+ { creatureo X } query
+] unit-test
+
+creatureo clear-pred
+{ creatureo Y } {
+ { cato Y } ;; { mouseo Y }
+} rule
+{ "cato" } [
+ creatureo get defs>> first second first pred>> name>>
+] unit-test
+{ "mouseo" } [
+ creatureo get defs>> second second first pred>> name>>
+] unit-test
+
+creatureo clear-pred
+{ creatureo Y } {
+ { cato Y } ;; { mouseo Y }
+} rule*
+{ "cato" } [
+ creatureo get defs>> first second first pred>> name>>
+] unit-test
+{ "mouseo" } [
+ creatureo get defs>> second second first pred>> name>>
+] unit-test
+
+{ { H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } } } } [
+ { creatureo X } query
+] unit-test
+
+{ { H{ { Y Tom } } H{ { Y Jerry } } } } [
+ { creatureo Y } 2 query-n
+] unit-test
+
+SYMBOL: Spike
+LOGIC-PREDS: dogo ;
+{ dogo Spike } fact
+creatureo clear-pred
+{ creatureo X } { dogo X } rule
+{ creatureo Y } {
+ { cato Y } ;; { mouseo Y }
+} rule
+{ "dogo" } [
+ creatureo get defs>> first second first pred>> name>>
+] unit-test
+{ "cato" } [
+ creatureo get defs>> second second first pred>> name>>
+] unit-test
+{ "mouseo" } [
+ creatureo get defs>> third second first pred>> name>>
+] unit-test
+
+creatureo clear-pred
+{ creatureo X } { dogo X } rule
+{ creatureo Y } {
+ { cato Y } ;; { mouseo Y }
+} rule*
+{ "cato" } [
+ creatureo get defs>> first second first pred>> name>>
+] unit-test
+{ "mouseo" } [
+ creatureo get defs>> second second first pred>> name>>
+] unit-test
+{ "dogo" } [
+ creatureo get defs>> third second first pred>> name>>
+] unit-test
+
+creatureo clear-pred
+{ creatureo Y } {
+ { cato Y } ;; { mouseo Y }
+} rule
+
+LOGIC-PREDS: likes-cheeseo dislikes-cheeseo ;
+{ likes-cheeseo X } { mouseo X } rule
+{ dislikes-cheeseo Y } {
+ { creatureo Y }
+ \+ { likes-cheeseo Y }
+} rule
+
+{ f } [ { dislikes-cheeseo Jerry } query ] unit-test
+{ t } [ { dislikes-cheeseo Tom } query ] unit-test
+
+{ L{ Tom Jerry Nibbles } } [ L{ Tom Jerry Nibbles } ] unit-test
+{ t } [ { membero Jerry L{ Tom Jerry Nibbles } } query ] unit-test
+
+{ f } [
+ { membero Spike [ Tom Jerry Nibbles L{ } cons cons cons ] } query
+] unit-test
+
+TUPLE: house living dining kitchen in-the-wall ;
+LOGIC-PREDS: houseo ;
+{ houseo T{ house
+ { living Tom }
+ { dining f }
+ { kitchen Nibbles }
+ { in-the-wall Jerry }
+ }
+} fact
+
+{ { H{ { X Nibbles } } } } [
+ { houseo T{ house
+ { living __ }
+ { dining __ }
+ { kitchen X }
+ { in-the-wall __ }
+ }
+ } query
+] unit-test
+
+LOGIC-PREDS: is-ao consumeso ;
+SYMBOLS: mouse cat milk cheese fresh-milk Emmentaler ;
+{
+ { is-ao Tom cat }
+ { is-ao Jerry mouse }
+ { is-ao Nibbles mouse }
+ { is-ao fresh-milk milk }
+ { is-ao Emmentaler cheese }
+} facts
+{
+ {
+ { consumeso X milk } {
+ { is-ao X mouse } ;;
+ { is-ao X cat }
+ }
+ }
+ { { consumeso X cheese } { is-ao X mouse } }
+ { { consumeso Tom mouse } { !! f } }
+ { { consumeso X mouse } { is-ao X cat } }
+} rules
+
+{
+ {
+ H{ { X milk } { Y fresh-milk } }
+ H{ { X cheese } { Y Emmentaler } }
+ }
+} [
+ { { consumeso Jerry X } { is-ao Y X } } query
+] unit-test
+{ { H{ { X milk } { Y fresh-milk } } } } [
+ { { consumeso Tom X } { is-ao Y X } } query
+] unit-test
+
+SYMBOL: a-cat
+{ is-ao a-cat cat } fact
+{ {
+ H{ { X milk } { Y fresh-milk } }
+ H{ { X mouse } { Y Jerry } }
+ H{ { X mouse } { Y Nibbles } }
+ }
+} [
+ { { consumeso a-cat X } { is-ao Y X } } query
+] unit-test
+
+cato clear-pred
+mouseo clear-pred
+{ f } [ { creatureo X } query ] unit-test
+
+{ cato Tom } fact
+{ mouseo Jerry } fact
+{ mouseo Nibbles } fact*
+{ { H{ { Y Nibbles } } H{ { Y Jerry } } } } [
+ { mouseo Y } query
+] unit-test
+
+{ mouseo Jerry } retract
+{ { H{ { X Nibbles } } } } [
+ { mouseo X } query
+] unit-test
+
+{ mouseo Jerry } fact
+{ { H{ { X Nibbles } } H{ { X Jerry } } } } [
+ { mouseo X } query
+] unit-test
+{ mouseo __ } retract-all
+{ f } [ { mouseo X } query ] unit-test
+
+{ { mouseo Jerry } { mouseo Nibbles } } facts
+SYMBOLS: big small a-big-cat a-small-cat ;
+{ cato big a-big-cat } fact
+{ cato small a-small-cat } fact
+{ { H{ { X Tom } } } } [ { cato X } query ] unit-test
+{
+ {
+ H{ { X big } { Y a-big-cat } }
+ H{ { X small } { Y a-small-cat } }
+ }
+} [ { cato X Y } query ] unit-test
+{
+ { H{ { X Tom } } H{ { X Jerry } } H{ { X Nibbles } } }
+} [ { creatureo X } query ] unit-test
+
+{ cato __ __ } retract-all
+{ f } [ { cato X Y } query ] unit-test
+{ { H{ { X Tom } } } } [ { cato X } query ] unit-test
+
+LOGIC-PREDS: factorialo N_>_0 N2_is_N_-_1 F_is_F2_*_N ;
+LOGIC-VARS: N N2 F F2 ;
+{ factorialo 0 1 } fact
+{ factorialo N F } {
+ { N_>_0 N }
+ { N2_is_N_-_1 N2 N }
+ { factorialo N2 F2 }
+ { F_is_F2_*_N F F2 N }
+} rule
+{ N_>_0 N } [ N of 0 > ] callback
+{
+ { { N2_is_N_-_1 N2 N } [ dup N of 1 - N2 unify ] }
+ { { F_is_F2_*_N F F2 N } [ dup [ N of ] [ F2 of ] bi * F unify ] }
+} callbacks
+
+{ { H{ { F 1 } } } } [ { factorialo 0 F } query ] unit-test
+{ { H{ { F 1 } } } } [ { factorialo 1 F } query ] unit-test
+{ { H{ { F 3628800 } } } } [ { factorialo 10 F } query ] unit-test
+
+factorialo clear-pred
+{ factorialo 0 1 } fact
+{ factorialo N F } {
+ { (>) N 0 }
+ [ [ N of 1 - ] N2 is ]
+ { factorialo N2 F2 }
+ [ [ [ F2 of ] [ N of ] bi * ] F is ]
+} rule
+
+{ { H{ { F 1 } } } } [ { factorialo 0 F } query ] unit-test
+{ { H{ { F 1 } } } } [ { factorialo 1 F } query ] unit-test
+{ { H{ { F 3628800 } } } } [ { factorialo 10 F } query ] unit-test
--- /dev/null
+! Copyright (C) 2019-2020 KUSUMOTO Norio.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes classes.tuple combinators
+combinators.short-circuit compiler.units continuations
+formatting fry io kernel lexer lists locals make math multiline
+namespaces parser prettyprint prettyprint.backend prettyprint.config
+prettyprint.custom prettyprint.sections quotations sequences
+sequences.deep sets splitting strings words words.symbol
+vectors ;
+
+IN: factlog
+
+SYMBOL: !! ! cut operator in prolog: !
+SYMBOL: __ ! anonymous variable in prolog: _
+SYMBOL: ;; ! disjunction, or in prolog: ;
+SYMBOL: \+ ! negation in prolog: not, \+
+
+<PRIVATE
+
+<<
+TUPLE: logic-pred name defs ;
+
+: <pred> ( name -- pred )
+ logic-pred new
+ swap >>name
+ V{ } clone >>defs ;
+
+MIXIN: LOGIC-VAR
+SINGLETON: NORMAL-LOGIC-VAR
+SINGLETON: ANONYMOUSE-LOGIC-VAR
+INSTANCE: NORMAL-LOGIC-VAR LOGIC-VAR
+INSTANCE: ANONYMOUSE-LOGIC-VAR LOGIC-VAR
+
+: logic-var? ( obj -- ? )
+ dup symbol? [ get LOGIC-VAR? ] [ drop f ] if ; inline
+
+SYMBOLS: *trace?* *trace-depth* ;
+
+PRIVATE>
+
+: trace ( -- ) t *trace?* set-global ;
+
+: notrace ( -- ) f *trace?* set-global ;
+
+SYNTAX: LOGIC-VARS: ";"
+ [
+ create-word-in
+ [ reset-generic ]
+ [ define-symbol ]
+ [ NORMAL-LOGIC-VAR swap set-global ] tri
+ ] each-token ;
+
+SYNTAX: LOGIC-PREDS: ";"
+ [
+ create-word-in
+ [ reset-generic ]
+ [ define-symbol ]
+ [ [ name>> <pred> ] keep set-global ] tri
+ ] each-token ;
+>>
+
+SYNTAX: %!
+ "!%" parse-multiline-string drop ;
+
+<PRIVATE
+
+TUPLE: logic-goal pred args ;
+
+: called-args ( args -- args' )
+ [ dup callable? [ call( -- term ) ] when ] map ;
+
+:: <goal> ( pred args -- goal )
+ pred get args called-args logic-goal boa ; inline
+
+: def>goal ( goal-def -- goal ) unclip swap <goal> ; inline
+
+: normalize ( goal-def/defs -- goal-defs )
+ dup {
+ [ !! = ]
+ [ ?first dup symbol? [ get logic-pred? ] [ drop f ] if ]
+ } 1|| [ 1array ] when ;
+
+TUPLE: logic-env table ;
+
+: <env> ( -- env ) logic-env new H{ } clone >>table ; inline
+
+:: env-put ( x pair env -- ) pair x env table>> set-at ; inline
+
+: env-get ( x env -- pair/f ) table>> at ; inline
+
+: env-delete ( x env -- ) table>> delete-at ; inline
+
+: env-clear ( env -- ) table>> clear-assoc ; inline
+
+: dereference ( term env -- term' env' )
+ [ 2dup env-get [ 2nip first2 t ] [ f ] if* ] loop ;
+
+PRIVATE>
+
+M: logic-env at*
+ dereference {
+ { [ over logic-goal? ] [
+ [ [ pred>> ] [ args>> ] bi ] dip at <goal> t ] }
+ { [ over tuple? ] [
+ '[ tuple-slots [ _ at ] map ]
+ [ class-of slots>tuple ] bi t ] }
+ { [ over sequence? ] [
+ '[ _ at ] map t ] }
+ [ drop t ]
+ } cond ;
+
+<PRIVATE
+
+TUPLE: callback-env env trail ;
+
+C: <callback-env> callback-env
+
+M: callback-env at* env>> at* ;
+
+TUPLE: cut-info cut? ;
+
+C: <cut> cut-info
+
+: cut? ( cut-info -- ? ) cut?>> ; inline
+
+: set-info ( ? cut-info -- ) cut?<< ; inline
+
+: set-info-if-f ( ? cut-info -- )
+ dup cut?>> [ 2drop ] [ cut?<< ] if ; inline
+
+DEFER: unify*
+
+:: (unify*) ( x! x-env! y! y-env! trail tmp-env -- success? )
+ f :> ret-value! f :> ret?! f :> ret2?!
+ t :> loop?!
+ [ loop? ] [
+ { { [ x logic-var? ] [
+ x x-env env-get :> xp!
+ xp not [
+ y y-env dereference y-env! y!
+ x y = x-env y-env eq? and [
+ x { y y-env } x-env env-put
+ x-env tmp-env eq? [
+ { x x-env } trail push
+ ] unless
+ ] unless
+ f loop?! t ret?! t ret-value!
+ ] [
+ xp first2 x-env! x!
+ x x-env dereference x-env! x!
+ ] if ] }
+ { [ y logic-var? ] [
+ x y x! y! x-env y-env x-env! y-env! ] }
+ [ f loop?! ]
+ } cond
+ ] while
+ ret? [
+ t ret-value!
+ x y [ logic-goal? ] both? [
+ x pred>> y pred>> = [
+ x args>> x! y args>> y!
+ ] [
+ f ret-value! t ret2?!
+ ] if
+ ] when
+ ret2? [
+ {
+ { [ x y [ tuple? ] both? ] [
+ x y [ class-of ] same? [
+ x y [ tuple-slots ] bi@ :> ( x-slots y-slots )
+ 0 :> i! x-slots length 1 - :> stop-i t :> loop?!
+ [ i stop-i <= loop? and ] [
+ x-slots y-slots [ i swap nth ] bi@
+ :> ( x-item y-item )
+ x-item x-env y-item y-env trail tmp-env unify* [
+ f loop?!
+ f ret-value!
+ ] unless
+ i 1 + i!
+ ] while
+ ] [ f ret-value! ] if ] }
+ { [ x y [ sequence? ] both? ] [
+ x y [ class-of ] same? x y [ length ] same? and [
+ 0 :> i! x length 1 - :> stop-i t :> loop?!
+ [ i stop-i <= loop? and ] [
+ x y [ i swap nth ] bi@ :> ( x-item y-item )
+ x-item x-env y-item y-env trail tmp-env unify* [
+ f loop?!
+ f ret-value!
+ ] unless
+ i 1 + i!
+ ] while
+ ] [ f ret-value! ] if ] }
+ [ x y = ret-value! ]
+ } cond
+ ] unless
+ ] unless
+ ret-value ;
+
+:: unify* ( x x-env y y-env trail tmp-env -- success? )
+ *trace?* get-global :> trace?
+ 0 :> depth!
+ trace? [
+ *trace-depth* counter depth!
+ depth [ "\t" printf ] times
+ "Unification of " printf x-env x of pprint
+ " and " printf y pprint nl
+ ] when
+ x x-env y y-env trail tmp-env (unify*) :> success?
+ trace? [
+ depth [ "\t" printf ] times
+ success? [ "==> Success\n" ] [ "==> Fail\n" ] if "%s\n" printf
+ *trace-depth* get-global 1 - *trace-depth* set-global
+ ] when
+ success? ;
+
+: each-until ( seq quot -- ) find 2drop ; inline
+
+:: resolve-body ( body env cut quot: ( -- ) -- )
+ body empty? [
+ quot call( -- )
+ ] [
+ body unclip :> ( rest-goals! first-goal! )
+ first-goal !! = [ ! cut
+ rest-goals env cut [ quot call( -- ) ] resolve-body
+ t cut set-info
+ ] [
+ first-goal callable? [
+ first-goal call( -- goal ) first-goal!
+ ] when
+ *trace?* get-global [
+ first-goal
+ [ pred>> name>> "in: { %s " printf ]
+ [ args>> [ "%u " printf ] each "}\n" printf ] bi
+ ] when
+ <env> :> d-env!
+ f <cut> :> d-cut!
+ first-goal pred>> defs>> [
+ first2 :> ( d-head d-body )
+ first-goal d-head [ args>> length ] same? [
+ d-cut cut? cut cut? or [ t ] [
+ V{ } clone :> trail
+ first-goal env d-head d-env trail d-env unify* [
+ d-body callable? [
+ d-env trail <callback-env> d-body call( cb-env -- ? ) [
+ rest-goals env cut [ quot call( -- ) ] resolve-body
+ ] when
+ ] [
+ d-body d-env d-cut [
+ rest-goals env cut [ quot call( -- ) ] resolve-body
+ cut cut? d-cut set-info-if-f
+ ] resolve-body
+ ] if
+ ] when
+ trail [ first2 env-delete ] each
+ d-env env-clear
+ f
+ ] if
+ ] [ f ] if
+ ] each-until
+ ] if
+ ] if ;
+
+: split-body ( body -- bodies ) { ;; } split [ >array ] map ;
+
+SYMBOL: *anonymouse-var-no*
+
+: reset-anonymouse-var-no ( -- ) 0 *anonymouse-var-no* set-global ;
+
+: proxy-var-for-'__' ( -- var-symbol )
+ [
+ *anonymouse-var-no* counter "ANON-%d_" sprintf
+ "factlog.private" create-word dup dup
+ define-symbol
+ ANONYMOUSE-LOGIC-VAR swap set-global
+ ] with-compilation-unit ;
+
+: replace-'__' ( before -- after )
+ {
+ { [ dup __ = ] [ drop proxy-var-for-'__' ] }
+ { [ dup sequence? ] [ [ replace-'__' ] map ] }
+ { [ dup tuple? ] [
+ [ tuple-slots [ replace-'__' ] map ]
+ [ class-of slots>tuple ] bi ] }
+ [ ]
+ } cond ;
+
+: collect-logic-vars ( seq -- vars-array )
+ [ logic-var? ] deep-filter members ;
+
+:: (resolve) ( goal-def/defs quot: ( env -- ) -- )
+ goal-def/defs replace-'__' normalize [ def>goal ] map :> goals
+ <env> :> env
+ goals env f <cut> [ env quot call( env -- ) ] resolve-body ;
+
+: resolve ( goal-def/defs quot: ( env -- ) -- ) (resolve) ;
+
+: resolve* ( goal-def/defs -- ) [ drop ] resolve ;
+
+SYMBOL: dummy-item
+
+:: negation-goal ( goal -- negation-goal )
+ "failo_" <pred> :> f-pred
+ f-pred { } clone logic-goal boa :> f-goal
+ V{ { f-goal [ drop f ] } } f-pred defs<<
+ "trueo_" <pred> :> t-pred
+ t-pred { } clone logic-goal boa :> t-goal
+ V{ { t-goal [ drop t ] } } t-pred defs<<
+ goal pred>> name>> "\\+%s_" sprintf <pred> :> negation-pred
+ negation-pred goal args>> clone logic-goal boa :> negation-goal
+ V{
+ { negation-goal { goal !! f-goal } }
+ { negation-goal { t-goal } }
+ } negation-pred defs<< ! \+P_ { P !! { failo_ } ;; { trueo_ } } rule
+ negation-goal ;
+
+SYMBOLS: at-the-beginning at-the-end ;
+
+:: (rule) ( head body pos -- )
+ reset-anonymouse-var-no
+ head replace-'__' def>goal :> head-goal
+ body replace-'__' normalize
+ split-body pos at-the-beginning = [ reverse ] when ! disjunction
+ dup empty? [
+ head-goal swap 2array 1vector
+ head-goal pred>> [
+ pos at-the-end = [ swap ] when append!
+ ] change-defs drop
+ ] [
+ f :> negation?!
+ [
+ [
+ {
+ { [ dup \+ = ] [ drop dummy-item t negation?! ] }
+ { [ dup array? ] [
+ def>goal negation? [ negation-goal ] when
+ f negation?! ] }
+ { [ dup callable? ] [
+ call( -- goal ) negation? [ negation-goal ] when
+ f negation?! ] }
+ { [ dup [ t = ] [ f = ] bi or ] [
+ :> t/f! negation? [ t/f not t/f! ] when
+ t/f "trueo_" "failo_" ? <pred> :> t/f-pred
+ t/f-pred { } clone logic-goal boa :> t/f-goal
+ V{ { t/f-goal [ drop t/f ] } } t/f-pred defs<<
+ t/f-goal
+ f negation?! ] }
+ { [ dup !! = ] [ f negation?! ] } ! as '!!'
+ [ drop dummy-item f negation?! ]
+ } cond
+ ] map dummy-item swap remove :> body-goals
+ V{ { head-goal body-goals } }
+ head-goal pred>> [
+ pos at-the-end = [ swap ] when append!
+ ] change-defs drop
+ ] each
+ ] if ;
+
+: (fact) ( head pos -- ) { } clone swap (rule) ;
+
+PRIVATE>
+
+: rule ( head body -- ) at-the-end (rule) ; inline
+
+: rule* ( head body -- ) at-the-beginning (rule) ; inline
+
+: rules ( defs -- ) [ first2 rule ] each ; inline
+
+: fact ( head -- ) at-the-end (fact) ; inline
+
+: fact* ( head -- ) at-the-beginning (fact) ; inline
+
+: facts ( defs -- ) [ fact ] each ; inline
+
+:: callback ( head quot: ( callback-env -- ? ) -- )
+ head def>goal :> head-goal
+ head-goal pred>> [
+ { head-goal quot } suffix!
+ ] change-defs drop ;
+
+: callbacks ( defs -- ) [ first2 callback ] each ; inline
+
+:: retract ( head-def -- )
+ head-def replace-'__' def>goal :> head-goal
+ head-goal pred>> defs>> :> defs
+ defs [ first <env> head-goal <env> V{ } clone <env> (unify*) ] find [
+ head-goal pred>> [ remove-nth! ] change-defs drop
+ ] [ drop ] if ;
+
+:: retract-all ( head-def -- )
+ head-def replace-'__' def>goal :> head-goal
+ head-goal pred>> defs>> :> defs
+ defs [
+ first <env> head-goal <env> V{ } clone <env> (unify*)
+ ] reject! head-goal pred>> defs<< ;
+
+: clear-pred ( pred -- ) get V{ } clone swap defs<< ;
+
+:: unify ( cb-env x y -- success? )
+ cb-env env>> :> env
+ x env y env cb-env trail>> env (unify*) ;
+
+:: is ( quot: ( env -- value ) dist -- goal )
+ quot collect-logic-vars
+ dup dist swap member? [ dist suffix ] unless :> args
+ quot dist "[ %u %s is ]" sprintf <pred> :> is-pred
+ is-pred args logic-goal boa :> is-goal
+ V{
+ {
+ is-goal
+ [| env | env dist env quot call( env -- value ) unify ]
+ }
+ } is-pred defs<<
+ is-goal ;
+
+:: =:= ( quot: ( env -- n m ) -- goal )
+ quot collect-logic-vars :> args
+ quot "[ %u =:= ]" sprintf <pred> :> =:=-pred
+ =:=-pred args logic-goal boa :> =:=-goal
+ V{
+ {
+ =:=-goal
+ [| env |
+ env quot call( env -- n m )
+ 2dup [ number? ] both? [ = ] [ 2drop f ] if ]
+ }
+ } =:=-pred defs<<
+ =:=-goal ;
+
+:: =\= ( quot: ( env -- n m ) -- goal )
+ quot collect-logic-vars :> args
+ quot "[ %u =\\= ]" sprintf <pred> :> =\=-pred
+ =\=-pred args logic-goal boa :> =\=-goal
+ V{
+ {
+ =\=-goal
+ [| env |
+ env quot call( env -- n m )
+ 2dup [ number? ] both? [ = not ] [ 2drop f ] if ]
+ }
+ } =\=-pred defs<<
+ =\=-goal ;
+
+:: invoke ( quot: ( env -- ) -- goal )
+ quot collect-logic-vars :> args
+ quot "[ %u invoke ]" sprintf <pred> :> invoke-pred
+ invoke-pred args logic-goal boa :> invoke-goal
+ V{
+ { invoke-goal [| env | env quot call( env -- ) t ] }
+ } invoke-pred defs<<
+ invoke-goal ;
+
+:: invoke* ( quot: ( env -- ? ) -- goal )
+ quot collect-logic-vars :> args
+ quot "[ %u invoke* ]" sprintf <pred> :> invoke*-pred
+ invoke*-pred args logic-goal boa :> invoke*-goal
+ V{
+ { invoke*-goal [| env | env quot call( env -- ? ) ] }
+ } invoke*-pred defs<<
+ invoke*-goal ;
+
+:: query-n ( goal-def/defs n/f -- bindings-array/success? )
+ *trace?* get-global :> trace?
+ 0 :> n!
+ f :> success?!
+ V{ } clone :> bindings
+ [
+ goal-def/defs normalize [| env |
+ env table>> keys [ get NORMAL-LOGIC-VAR? ] filter
+ [ dup env at ] H{ } map>assoc
+ trace? get-global [ dup [ "%u: %u\n" printf ] assoc-each ] when
+ bindings push
+ t success?!
+ n/f [
+ n 1 + n!
+ n n/f >= [ return ] when
+ ] when
+ ] (resolve)
+ ] with-return
+ bindings dup {
+ [ empty? ]
+ [ first keys [ get NORMAL-LOGIC-VAR? ] any? not ]
+ } 1|| [ drop success? ] [ >array ] if ;
+
+: query ( goal-def/defs -- bindings-array/success? ) f query-n ;
+
+
+! Built-in predicate definitions -----------------------------------------------------
+
+LOGIC-PREDS:
+ trueo failo
+ varo nonvaro
+ (<) (>) (>=) (=<) (==) (\==) (=) (\=)
+ writeo writenlo nlo
+ membero appendo lengtho listo
+;
+
+{ trueo } [ drop t ] callback
+
+{ failo } [ drop f ] callback
+
+
+<PRIVATE LOGIC-VARS: A B C X Y Z ; PRIVATE>
+
+{ varo X } [ X of logic-var? ] callback
+
+{ nonvaro X } [ X of logic-var? not ] callback
+
+
+{ (<) X Y } [
+ [ X of ] [ Y of ] bi 2dup [ number? ] both? [ < ] [ 2drop f ] if
+] callback
+
+{ (>) X Y } [
+ [ X of ] [ Y of ] bi 2dup [ number? ] both? [ > ] [ 2drop f ] if
+] callback
+
+{ (>=) X Y } [
+ [ X of ] [ Y of ] bi 2dup [ number? ] both? [ >= ] [ 2drop f ] if
+] callback
+
+{ (=<) X Y } [
+ [ X of ] [ Y of ] bi 2dup [ number? ] both? [ <= ] [ 2drop f ] if
+] callback
+
+{ (==) X Y } [ [ X of ] [ Y of ] bi = ] callback
+
+{ (\==) X Y } [ [ X of ] [ Y of ] bi = not ] callback
+
+{ (=) X Y } [ dup [ X of ] [ Y of ] bi unify ] callback
+
+{ (\=) X Y } [
+ clone [ clone ] change-env [ clone ] change-trail
+ dup [ X of ] [ Y of ] bi unify not
+] callback
+
+
+{ writeo X } [
+ X of dup sequence? [
+ [ dup string? [ printf ] [ pprint ] if ] each
+ ] [
+ dup string? [ printf ] [ pprint ] if
+ ] if t
+] callback
+
+{ writenlo X } [
+ X of dup sequence? [
+ [ dup string? [ printf ] [ pprint ] if ] each
+ ] [
+ dup string? [ printf ] [ pprint ] if
+ ] if nl t
+] callback
+
+{ nlo } [ drop nl t ] callback
+
+
+{ membero X L{ X . Z } } fact
+{ membero X L{ Y . Z } } { membero X Z } rule
+
+{ appendo L{ } A A } fact
+{ appendo L{ A . X } Y L{ A . Z } } {
+ { appendo X Y Z }
+} rule
+
+
+<PRIVATE LOGIC-VARS: Tail N N1 ; PRIVATE>
+
+{ lengtho L{ } 0 } fact
+{ lengtho L{ __ . Tail } N } {
+ { lengtho Tail N1 }
+ [ [ N1 of 1 + ] N is ]
+} rule
+
+
+<PRIVATE LOGIC-VARS: L ; PRIVATE>
+
+{ listo L{ } } fact
+{ listo L{ __ . __ } } fact
projects / factor.git / commitdiff