factlog
kusumotonorio
parent
583e0470c4
commit
9a94c2d54d
|
|
@ -0,0 +1,12 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,15 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,12 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,18 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,8 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,21 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,20 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,25 @@
|
||||||
|
! 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
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,20 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,17 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,31 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,60 @@
|
||||||
|
! 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 ;
|
||||||
|
|
@ -0,0 +1,10 @@
|
||||||
|
! 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
|
||||||
|
|
||||||
|
|
@ -0,0 +1,36 @@
|
||||||
|
! 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
|
||||||
|
|
||||||
|
|
@ -0,0 +1,54 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,47 @@
|
||||||
|
! 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
|
||||||
|
|
||||||
|
|
@ -0,0 +1,54 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,61 @@
|
||||||
|
! 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
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,269 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,576 @@
|
||||||
|
! 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 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 ;
|
||||||
|
>>
|
||||||
|
|
||||||
|
<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
|
||||||
|
|
||||||
Loading…
Reference in New Issue