\ Backtracking search example from Townsend & Feucht

20 newlist GOALS
20 newlist SOLVED
200 newlist CLAUSES

: get-goal ( -- goal )
   GOALS @ dup first swap tail GOALS swap set ;

: find-clause ( goal @clauses1 -- goal @clauses2 )
   begin 2dup first first dup >r = >r null or not
   while tail
   repeat
;

: find-clause? ( goal @ clause -- flag )
\ find matching clause & put on SOLVED
\ flag is true if clause is found
   find-clause dup null dup >r
   if 2drop
   else SOLVED cons SOLVED cons
   then r> not
;

: backtrack ( -- flag )
\ flag = false if SOLVED list empty
   SOLVED @ dup first swap tail first tail
   SOLVED dup @ tail tail set find-clause? dup
   if add-goals then
;

: (search) ( -- flag true | false )
\ flag = true => succeed
   GOALS @ null not
   if get-goal CLAUSES @ find-clause?
      if add-goals false
      else backtrack
         if false else false true then
      then
   else true dup
   then
;

: search ( -- flag )
\ flag = true => succeed
   begin (search)
      until
;

: how?
   SOLVED @ dup null
   if print
   else
      begin dup null not
      while dup tail first first print tail tail
       repeat drop
   then
;

: nuf?
   key? if key drop key 13 =
   else false
   then
;

: trace
\ trace search
   begin cr ." GOALS:" GOALS @ print
      cr ." SOLVED:" how? cr (search) dup >r
      if
         if ." succeed" else ." fail" cr then
      then r> nuf? or
   until
;