#!/home/fx5/xper/rebol
REBOL []

; do http://proton/REBOL/bugfixes.r

knowledge-base: [
	(:- ('= A B) ('do match 'A 'B))

	(:-
		('. X Y)
		('do_then
			either (get-value 'Y) <> first ['true] [
				solve/then get-value 'X to-paren reduce [first ['.] get-value 'Y :then-clausel]
			] [
				solve/then get-value 'X :then-clausel
			]
	)	)

	(:-
		('.. X Y)
		('do_then
		    use [tc] copy/deep [
			tc: :then-clausel
			any [
				solve/then :X :then-clausel
				solve/then :Y :tc
			]
		    ]
	)	)

	(:-
		('not X)
		('do_then
		    use [tc ticket] copy/deep [
			tc: :then-clausel
			ticket: get-ticket
			either all [paren? :X not solve :X] [
				restore-vars ticket
				solve :tc
			] [
				restore-vars ticket
				false
			]
		    ]
		)
	)

	(:-
		('print X)
		('do pl-print get-value 'X true)
	)
	(:-
		('is X Y)
		('do
			match 'X math-calc :Y
		)
	)
	(:-
		'trace
		('do
			if all [value? 'global-trace-data block? :global-trace-data] [
				print ""
				foreach var global-trace-data [
					print [var "=" pl-print/string get-value var]
				]
				any [
					empty? global-trace-data
					not true = confirm "Retry?"
				]
			]
		)
	)
	(:-
		('assert X)
		('do
			append/only knowledge-base first bind/copy reduce [get-value 'X] 'self
			true
		)
	)
	(:-
		('retract X)
		('do_then
		    use [kb ticket tc] copy/deep [
			kb: knowledge-base
			tc: :then-clausel
			ticket: get-ticket
			while [not empty? kb] [
				either match kb/1 :X [
					remove kb
					if solve :tc [return true]
					restore-vars ticket
				] [
					restore-vars ticket
					kb: next kb
				]
			]
		    ]
		)
	)
]
infixes: compose [
	:-			50
	'..			100
	'.			200
	'=			300
	'is			300
	'=..			300
	(to-lit-word "<>")	300
	(to-lit-word ">")	300
	(to-lit-word "<")	300
	(to-lit-word ">=")	300
	(to-lit-word "<=")	300
	'+			500
	'-			500
	(to-lit-word "*")	700
	(to-lit-word "/")	700
]

reverse head sort/skip head reverse infixes 2

pl-print: func [sth /string /no-start /local out mrk] [
	out: copy ""
	mrk: no
	catch/name [ switch/default to-word mold type? :sth [
	    block! [
		append out "["
		while [all [block? :sth not empty? :sth]] [
			either mrk [append out ", "] [mrk: yes]
			append out pl-print/string first :sth
			sth: second :sth
		]
		if not block? :sth [
			either mrk [append out "|"] [mrk: yes]
			append out pl-print/string :sth
		]
		append out "]"
	    ]
	    paren! [
		if all [(length? :sth) = 3 find infixes first :sth] [
			append out rejoin [
				either no-start [""] ["("]
				pl-print/string second :sth " "
				pl-print/string first :sth " "
				pl-print/string third :sth
				either no-start [""] [")"]
			]
			throw/name none 'switch
		]
		append out pl-print/string first :sth
		either find ['do 'do_then] first :sth [
			append out mold next :sth
		] [
			append out "("
			foreach e next :sth [
				either mrk [append out ", "] [mrk: yes]
				append out pl-print/string :e
			]
			append out ")"
		]
	    ]
	    word! [
		append out uppercase to-string :sth
	    ]
	    lit-word! [
		append out lowercase switch/default :sth [. [","] .. [";"]] [to-string :sth]
	    ]
	] [
		append out mold :sth
	]] 'switch
	either string [out] [print out]
]

match: func [val1 val2 /with vars /local ok] [
	; probe reduce [vars :val1 :val2 with]
	if same? :val1 :val2 [return true]
	if word? :val1 [
	    either value? :val1 [
		return match get :val1 :val2
	    ] [
		either all [word? :val2 value? :val2] [
			return match get :val2 :val1
		] [
			save-var :val1
			set :val1 :val2
			return true
		]
	    ]
	]
	if word? :val2 [return match :val2 :val1 append vars]
	if all [any-block? :val1 any-block? :val2] [
		if (length? :val1) <> (length? :val2) [return false]
		ok: true
		foreach e :val1 [
			if not ok: match :e first :val2 [break]
			val2: next :val2
		]
		return ok
	]
	return :val1 = :val2
]

print-knowledge-base: does [
	foreach know knowledge-base [
		print rejoin [pl-print/string/no-start :know "."]
	]
]

vars-mem: []

get-ticket: does [(length? vars-mem) + 1]

save-var: func [var [word!]] [
	repend vars-mem [var reduce [get/any var]]
;	print length? vars-mem
]

restore-vars: func [ticket [integer!] /local word value] [
	; print ["RESTORING:" ticket]
	for x (length? vars-mem) - 1 ticket -2 [
		set [word value] at vars-mem x
		set/any word first value
	]
	clear at vars-mem ticket
]

find-vars: func [know /with list] [
	if not with [list: make block! 0]
	if all [
		paren? :know
		find ['do 'do_then] first :know
	] [
		return list
	]
	either any-block? :know [
		foreach know :know [find-vars/with :know list]
	] [
		if word? :know [append list :know]
	]
	if not with [
		union list []
	]
]

prepare-knowledge: func [know /local tmp vars] [
	tmp: copy vars: find-vars :know
	forall tmp [change tmp to-set-word tmp/1]
	insert tmp [!: none]
	tmp: make object! head tmp
	save-var 'tmp
	unset bind vars in tmp 'self
	tmp/!: get-ticket
	first bind/copy reduce [:know] in tmp 'self
]

solve: func [clausel /then then-clausel /local ticket var int] [
  ticket: get-ticket
  if integer? set/any 'int catch [
	; pl-print :clausel
;	probe :clausel
	if (get-value 'clausel) == first ['!] [
		print "CUT!"
		probe :clausel
		if solve :then-clausel [return true]
		throw get bind '! :clausel
	]
	if word? :clausel [clausel: get-value :clausel]
	if not any [paren? :clausel lit-word? :clausel word? :clausel] [return false]
	if all [paren? :clausel (length? :clausel) = 1] [clausel: first :clausel]
	print [ticket mold :clausel]
	if not then [then-clausel: first ['true]]
	if :clausel = first ['true] [
		either then [return solve :then-clausel] [return true]
	]
	if paren? :clausel [
	    if (first :clausel) = first ['do_then] [
		system/words/then-clausel: :then-clausel
		return do next :clausel
	    ]
	    if (first :clausel) = first ['do] [
		return all [do next :clausel solve :then-clausel]
	    ]
	]
	foreach entry knowledge-base [
	    if any [
		lit-word? :clausel
		not lit-word? first :clausel
		lit-word? :entry
		(first :clausel) = (first :entry)
		all [
			(first :entry) = (first [:-])
		   any [
			all [
				paren? second :entry
				(first :clausel) = (first second :entry)
			]
			(first :clausel) = (second :entry)
		   ]
		]
	    ] [
		; probe get-value 'clausel
		entry: prepare-knowledge :entry
		either all [paren? :entry (first :entry) = first [:-]] [
			if match second :entry :clausel [
				if solve/then third :entry :then-clausel [return true]
			]
		] [
			if all [match :entry :clausel solve :then-clausel] [return true]
		]
		restore-vars ticket
	    ]
	]
	; print ["---> FALSCH:" pl-print/string :clausel pl-print/string :then-clausel reduce [get/any 'x]]
	return no
   ] [
	; CUT
	if ticket > int [ throw int ]
	false
   ] 
]

get-value: func [value /local out] [
	switch to-word mold type? :value [
	    word! [
		; print "WORD"
		if value? :value [
			return get-value get :value
		]
		return :value
	    ]
	    block! [
		; print "BLOCK"
		out: make block! length? :value
		foreach e :value [
			append/only out get-value :e
		]
		return :out
	    ]
	    paren! [
		either all [not tail? :value any [(first :value) = (first ['do]) (first :value) = (first ['do_then])]] [
			return :value
		] [
			out: make paren! length? :value
			foreach e :value [
				insert/only tail :out get-value :e
			]
			return :out
		]
	    ]
	]
	return :value
]

math-list: compose [
	'+ [add]
	'- [subtract]
	'* [multiply]
	(to-lit-word first [/]) [divide]
	'max [max]
	'min [min]
]

math-calc: func [fun /no-get /local tmp] [
	if not no-get [fun: get-value :fun]
	switch/default to-word mold type? :fun [
	    paren! [
		if (length? :fun) <> 3 [make error! [user message "argh"]]
		if tmp: select math-list first :fun [
			do get first tmp math-calc second :fun math-calc third :fun
		]
	    ]
	    word! [
		make error! [user message "not initialized Variable while calculation"]
	    ]
	] [
		return :fun
	]
]

pl-load: func [reb [any-block!] /local tmp1 tmp2 tmp3 tmp4 weiter out] [
	out: make paren! 0
	if not parse :reb [
		some [
			'! (
				insert/only tail :out first ['!]
			)
			| set tmp1 [word! | lit-word!] set tmp2 paren! (
			    either any [find infixes to-lit-word tmp1] [
				weiter: first ['this-does-not-match]
			    ] [
				weiter: []
				either any [tmp1 = 'do tmp1 = 'do_then] [
					tmp3: copy :tmp2
				] [
					tmp3: pl-load :tmp2
					while [tmp4: find :tmp3 first ['.]] [remove :tmp4]
				]
				insert :tmp3 to-lit-word :tmp1
				insert/only tail :out :tmp3
			    ]
			) weiter
			| set tmp1 paren! (
				insert/only tail :out pl-load :tmp1
			)
			| into [] (
				insert/only tail :out []
			)
			| set tmp1 block! (
				insert/only tail :out tmp2: copy []
				tmp1: pl-load :tmp1
				forall tmp1 [
					if (first :tmp1) <> (first ['.]) [
					    either (first :tmp1) = (first ['|]) [
						change/only next tmp3 first copy next :tmp1
						break
					    ] [
						insert tmp3: tmp2 reduce  [first :tmp1 tmp2: copy []]
					    ]
					]
				]
			)
			| set tmp1 skip (
				either all [any-word? :tmp1 find infixes to-lit-word :tmp1 (mold :tmp1) <> ":-"] [
					insert/only tail :out to-lit-word :tmp1
				] [
					insert/only tail :out :tmp1
				]
			)
		]
	] [make error! [user message "Parse error"]]
	return :out
]

pl-infix: func [reb [any-block!] /rec /local pos tmp] [
	if all [not tail? :reb (first :reb) = 'do] [exit]
	foreach test :reb [
		if any-block? :test [pl-infix/rec :test]
	]
	foreach [infix pri] infixes [
		while [any [pos: find/last :reb :infix pos: find/last :reb to-word :infix]] [
			if (length? :reb) = 3 [
				tmp: first :pos
				change/only :pos first :reb
				change/only :reb :tmp
				break
			]
			tmp: to-paren reduce [first :pos first back :pos second :pos]
			pos: remove/part back :pos 2
			change/only :pos :tmp
		]
	]
	; if all [not rec (length? :reb) <> 1] [make error! [user message "Parse-error 2"]]
	if all [(length? :reb) = 1 paren? first :reb] [
		tmp: first :reb
		remove :reb
		insert :reb :tmp
	]
	:reb
]

pl-ask: func [reb [block!] /local tmp] [
	reb: pl reb
	unset find-vars :reb
	tmp: solve :reb
	clear vars-mem
	return tmp
]

consult: func [inp /local e str lchar uchars tmp] [
   forever [
	str: copy ""
	while [any [empty? str not (last str) = #"."]] [
		if empty? inp [exit]
		parse/all inp [copy tmp [skip to newline | skip to end] inp:]
		if tmp [append str tmp]
	]
	remove back tail str
	if error? set/any 'e try [
		str: copy str
		foreach [from to] [
			"=" " = "
			"+" " + "
			"-" " - "
			": -" " :- "
			"/" " / "
			"*" " * "
			"," " . "
			";" " .. "
			">" " > "
			"<" " < "
			"<  >" "<>"
			">  =" ">="
			"<  =" "<="
			"\ =" " <> "
			"= .." " =.. "
		] [
			replace/all str from to
		]
		lchars: "abcdefghijklmnopqrstuvwxyzäöüß!"
		uchars: "ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜ"
		lchars: charset lchars
		parse/all str [any [
			  uchars any [uchars | lchars]
			| tmp: lchars (insert tmp "'") any [uchars | lchars]
			| skip
		]]
		str: pl-infix pl-load reduce ['assert to-paren reduce [to-paren load :str]]
		str: prepare-knowledge :str
		unset global-trace-data: find-vars :str
		solve :str
	] [
		print ["** REBlog-Fehler **" mold disarm e]
	]
	unset 'global-trace-data
	clear vars-mem
   ]
]

pl-interact: func [/local e str lchar uchars tmp] [
   forever [
	str: ask "REBlog >> "
	while [any [empty? str not (last str) = #"."]] [append str join " " ask "|"]
	remove back tail str
	if (trim/lines copy str) = "halt" [break]
	if error? set/any 'e try [
		str: copy str
		foreach [from to] [
			"=" " = "
			"+" " + "
			"-" " - "
			": -" " :- "
			"/" " / "
			"*" " * "
			"," " . "
			";" " .. "
			">" " > "
			"<" " < "
			"< >" "<>"
			"\ =" " <> "
			"= .." " =.. "
		] [
			replace/all str from to
		]
		lchars: "abcdefghijklmnopqrstuvwxyzäöüß"
		uchars: charset uppercase copy lchars
		lchars: charset lchars
		parse/all str [any [
			  uchars any [uchars | lchars]
			| tmp: lchars (insert tmp "'") any [uchars | lchars]
			| skip
		]]
		str: pl-infix pl-load reduce [to-paren load :str first ['.] first ['trace]]
		str: prepare-knowledge :str
		unset global-trace-data: find-vars :str
		probe :str
		print ["==" either solve :str ["yes"] ["no"] newline]
	] [
		print ["** REBlog-Fehler **" mold disarm e]
	]
	unset 'global-trace-data
	clear vars-mem
   ]
]

append knowledge-base to-block pl-infix pl-load [
	A <> B :- not(A = B)
	A > B :- do((get-value 'A) > (get-value 'B))
	A < B :- do((get-value 'A) < (get-value 'B))
	A >= B :- do((get-value 'A) >= (get-value 'B))
	A <= B :- do((get-value 'A) <= (get-value 'B))
	write(A) :- do(prin pl-print/string get-value 'A true)
	'nl :- do(print "" true)
	findall(A B C) :- do( use [bag bag2 ticket] copy/deep [
			bag2: bag: copy []
			recycle/off
			solve first [('.
				B
				('do 
					insert bag2 reduce [get-value 'A bag2: copy []]
					false
				)
			)]
			recycle/on
			match 'C 'bag
		]
	)
	A =.. B :- do( use [bag bag2 tmp] copy/deep [
		; probe get-value 'A
		either not word? get-value 'A [
			either lit-word? get-value 'A [
				match 'B [A []]
			] [ if paren? get-value 'A [
				bag: bag2: copy []
				foreach e get-value 'A [
					insert bag2 reduce [:e bag2: copy []]
				]
			    match bag 'B
			]]
		] [
			either block? tmp: get-value 'B [
				bag: make paren! 0
				while [not empty? tmp] [
					insert tail :bag first :tmp
					tmp: second :tmp
					if not block? :tmp [make error! [user message "Bad data"]]
				]
				match 'A to-paren :bag
			] [
				make error! [user message "=.. requires block"]
			]
		]
	])
	knowledge(X) :- do_then(use [ticket tc] copy/deep [
		ticket: get-ticket
		tc: :then-clausel
		foreach know knowledge-base [
			know: prepare-knowledge :know
			match 'know 'X
			if solve :tc [break/return true]
			restore-vars ticket
			false
		]
	])
	append([] A A)
	append([A | B] C [A | D]) :-
		append(B C D)

	listing(X) :-
		knowledge(A) .
		(A = (B :- C) .. B = A) .
		B =.. [X | Y] .
		write(A) . write(".") . 'nl .
		'false
]

append knowledge-base to-block pl-infix pl-load [

umdrehen(X Y) :-
        umdrehen(X [] Y)

umdrehen([] X X)

umdrehen([H | R] Rev Loes) :-
        umdrehen(R [H | Rev] Loes)

]

consult {
	greatest(A, [A1 | Y]) :- greatest(A2,Y), A is max(A1,A2).
	greatest(0, []).

	n2(X,Y):-findall(A,n(X,A),B),greatest(Y,B).

	n(X,Y):- v(X,Y).
	n(X,Z) :-v(X:-Y,Z1), n(Y,Z2), Z is min(Z1,Z2).
	n((X,Y),Z):-n(X,Z1), n(Y,Z2), Z is min(Z1,Z2).
	v(X,1):-X.

	human(sokrates).
	human(martin).
	human(frank).

	die(X):-human(X).
}

; pl-interact

()