Re: a golden oldie challenge: Eliza

On 22 Feb, 11:49, Mark Tarver <dr.mtar...@[EMAIL PROTECTED]
> wrote:
> Having got 3936 LOC through a 4000 LOC implementation, I thought I'd
> do some recreational
> hacking and do an old old program I've not looked at for some time -
> Eliza. =A0 You all know Eliza well enough for me not to have to spell it
> out. =A0The challenge is to implement or dig up an Eliza program (you
> don't have to write it yourself) in your favourite FPL. =A0Note that the
> script that drives Eliza's responses should not be counted towards the
> LOC count. =A0Some constraints.
>
> 1. =A0The script itself should be changeable by any novice. =A0That is
to
> say that it should not
> =A0 =A0 =A0be a pile of hard-wired code written in the native language
of
> the program or require
> =A0 =A0 =A0deep programming skills.
>
> 2. =A0The program should receive keyboard input from the user -
> including the usual punctuation
> =A0 =A0 =A0and any characters he wants to enter without crashing.
>
> During the Harrop Wars on comp.lang.lisp a lot of stuff was thrown
> around about the desirability of pattern matching. =A0The challenge is
> interesting because it involves a style of pattern-matching called
> 'segment pattern matching' that is not hard-wired into most FPLs and
> I'd like to see how well different FPLs cope with something outside
> the standard.
>
> Oh last thing; don't get too uptight about this. =A0It's only a bit of
> fun.
>
> Mark

Well here is my shot at it in Qi.  Total LOC excluding script is 70
LOC. You should run it under Qi 9.2 (latest release) because the
system function 'read-chars-as-stringlist' had a bug that was patched
in that release.  My script is very boring ;).

I looked for a Haskell/ML equivalent and found zilch.  Norvig's PAIP
contains a Lisp version in two files (eliza and eliza1) that is about
150 LOC excluding comments and script.

Mark
___________________________________________________________
(set *script* [
               [[X "like" Y] ["Why" "do" "you" "like" Y "?"]]
               [[X "father" Y] ["Tell me about your father."]]
               [[X] ["That's very interesting. Do go on."]]])

(define eliza
  -> (do (output "hi~%?- ") (eliza-loop (user) (value *script*))))

(define eliza-loop
  User Script -> (let Responses (map (/. S (pmatch User S)) Script)
                      Interesting (remove-if no-match? Responses)
                      ScriptError (if (empty? Interesting)
                                      (error "script failure!")
                                      _)
                      Choice (nth (+ (random (length Interesting)) 1)
Interesting)
                      Response (respond-with Choice)
                      Output (output "~{~A ~}~%~%?- " Response)
                      (eliza-loop (user) Script)))

(define respond-with
  [[] R] -> R
  [[[X V] | B] R] -> (respond-with [B (rep X R V)]))

(define no-match?
  [#\Escape _] -> true
  _ -> false)

(define user
  -> (read-chars-as-stringlist (user-loop (read-char _)) whitespace?))

(define whitespace?
  #\Space -> true
  #\Tab -> true
  #\, -> true
  #\. -> true
  _ -> false)

(define user-loop
  #\Newline -> []
  C -> [C | (user-loop (read-char _))])

(define remove-if
  _ [] -> []
  F [X | Y] -> (if (F X) (remove-if F Y) [X | (remove-if F Y)]))

(define pmatch
  User [I R] -> [(pmatch-help I User []) R])

(define pmatch-help
   X X B -> B
   [X | Y] [X | Z] B -> (pmatch-help Y Z B)
   [X | Y] Z B <- (let NilBind (nilbind X B)
                       ValX (value-in X NilBind)
                       (pmatch-help (rep X Y ValX) Z NilBind))
                       where (variable? X)
   [X | Y] [W | Z] B <- (pmatch-help [X | Y] Z (consbind X W B))
                         where (variable?
X)
   _ _ _ -> #\Escape)

(define nilbind
  X [] -> [[X []]]
  X [[X V] | B] -> [[X V] | B]
  X [Y | Z] -> [Y | (nilbind X Z)])

(define consbind
  X W [] -> [[X [W]]]
  X W [[X V] | B] -> [[X (append V [W])] | B]
  X W [Y | B] -> [Y | (consbind X W B)])

(define rep
  _ [] _ -> []
  X [X | Y] V -> (append V (rep X Y V))
  X [Y | Z] V -> [Y | (rep X Z V)])

(define value-in
  X B -> (head (tail (assoc X B))))