API's that Suck

May 28, 2009

Challenging SICP

Filed under: Uncategorized — Grauenwolf @ 6:30 am

Consider this logic problem in the realm of “nondeterministic computing”.

Baker, Cooper, Fletcher, Miller, and Smith live on different floors of an apartment house that contains only five floors. Baker does not live on the top floor. Cooper does not live on the bottom floor. Fletcher does not live on either the top or the bottom floor. Miller lives on a higher floor than does Cooper. Smith does not live on a floor adjacent to Fletcher’s. Fletcher does not live on a floor adjacent to Cooper’s. Where does everyone live?

This is the SICP solution to that problem:

 (define (multiple-dwelling)
  (let ((baker (amb 1 2 3 4 5))
        (cooper (amb 1 2 3 4 5))
        (fletcher (amb 1 2 3 4 5))
        (miller (amb 1 2 3 4 5))
        (smith (amb 1 2 3 4 5)))
    (require
     (distinct? (list baker cooper fletcher miller smith)))
    (require (not (= baker 5)))
    (require (not (= cooper 1)))
    (require (not (= fletcher 5)))
    (require (not (= fletcher 1)))
    (require (> miller cooper))
    (require (not (= (abs (- smith fletcher)) 1)))
    (require (not (= (abs (- fletcher cooper)) 1)))
    (list (list 'baker baker)
          (list 'cooper cooper)
          (list 'fletcher fletcher)
          (list 'miller miller)
          (list 'smith smith))))

SICP then goes on to explain how you need a “Metacircular Evaluator”, which is essentially a LISP parser that runs inside another LISP program. The author writes,

The driver loop for the amb evaluator is complex, due to the mechanism that permits the user to try again in evaluating an expression. The driver uses a procedure called internal-loop, which takes as argument a procedure try-again. The intent is that calling try-again should go on to the next untried alternative in the nondeterministic evaluation. Internal-loop either calls try-again in response to the user typing try-again at the driver loop, or else starts a new evaluation by calling ambeval.

Here are some of the components that go into the ambiguous evaluator.

(define (analyze-self-evaluating exp)
  (lambda (env succeed fail)
    (succeed exp fail)))

(define (analyze-quoted exp)
  (let ((qval (text-of-quotation exp)))
    (lambda (env succeed fail)
      (succeed qval fail))))

(define (analyze-variable exp)
  (lambda (env succeed fail)
    (succeed (lookup-variable-value exp env)
             fail)))

(define (analyze-lambda exp)
  (let ((vars (lambda-parameters exp))
        (bproc (analyze-sequence (lambda-body exp))))
    (lambda (env succeed fail)
      (succeed (make-procedure vars bproc env)
               fail))))

(define (analyze-if exp)
  (let ((pproc (analyze (if-predicate exp)))
        (cproc (analyze (if-consequent exp)))
        (aproc (analyze (if-alternative exp))))
    (lambda (env succeed fail)
      (pproc env
;; success continuation for evaluating the predicate
;; to obtain pred-value
             (lambda (pred-value fail2)
               (if (true? pred-value)
                   (cproc env succeed fail2)
                   (aproc env succeed fail2)))
;; failure continuation for evaluating the predicate
             fail))))

(define (analyze-sequence exps)
  (define (sequentially a b)
    (lambda (env succeed fail)
      (a env
;; success continuation for calling a
         (lambda (a-value fail2)
           (b env succeed fail2))
;; failure continuation for calling a
         fail)))
  (define (loop first-proc rest-procs)
    (if (null? rest-procs)
        first-proc
        (loop (sequentially first-proc (car rest-procs))
              (cdr rest-procs))))
  (let ((procs (map analyze exps)))
    (if (null? procs)
        (error "Empty sequence -- ANALYZE"))
    (loop (car procs) (cdr procs))))

(define (analyze-definition exp)
  (let ((var (definition-variable exp))
        (vproc (analyze (definition-value exp))))
    (lambda (env succeed fail)
      (vproc env                        
             (lambda (val fail2)
               (define-variable! var val env)
               (succeed 'ok fail2))
             fail))))

(define (analyze-assignment exp)
  (let ((var (assignment-variable exp))
        (vproc (analyze (assignment-value exp))))
    (lambda (env succeed fail)
      (vproc env
             (lambda (val fail2)        ; *1*
               (let ((old-value
                      (lookup-variable-value var env))) 
                 (set-variable-value! var val env)
                 (succeed 'ok
                          (lambda ()    ; *2*
                            (set-variable-value! var
                                                 old-value
                                                 env)
                            (fail2)))))
             fail))))

(define (analyze-application exp)
  (let ((fproc (analyze (operator exp)))
        (aprocs (map analyze (operands exp))))
    (lambda (env succeed fail)
      (fproc env
             (lambda (proc fail2)
               (get-args aprocs
                         env
                         (lambda (args fail3)
                           (execute-application
                            proc args succeed fail3))
                         fail2))
             fail))))

(define (get-args aprocs env succeed fail)
  (if (null? aprocs)
      (succeed '() fail)
      ((car aprocs) env
;; success continuation for this aproc
                    (lambda (arg fail2)
                      (get-args (cdr aprocs)
                                env
;; success continuation for recursive
;; call to get-args
                                (lambda (args fail3)
                                  (succeed (cons arg args)
                                           fail3))
                                fail2))
                    fail)))

 

(define (execute-application proc args succeed fail)
  (cond ((primitive-procedure? proc)
         (succeed (apply-primitive-procedure proc args)
                  fail))
        ((compound-procedure? proc)
         ((procedure-body proc)
          (extend-environment (procedure-parameters proc)
                              args
                              (procedure-environment proc))
          succeed
          fail))
        (else
         (error
          "Unknown procedure type -- EXECUTE-APPLICATION"
          proc))))

(define (analyze-amb exp)
  (let ((cprocs (map analyze (amb-choices exp))))
    (lambda (env succeed fail)
      (define (try-next choices)
        (if (null? choices)
            (fail)
            ((car choices) env
                           succeed
                           (lambda ()
                             (try-next (cdr choices))))))
      (try-next cprocs))))

(define input-prompt ";;; Amb-Eval input:")
(define output-prompt ";;; Amb-Eval value:")
(define (driver-loop)
  (define (internal-loop try-again)
    (prompt-for-input input-prompt)
    (let ((input (read)))
      (if (eq? input 'try-again)
          (try-again)
          (begin
            (newline)
            (display ";;; Starting a new problem ")
            (ambeval input
                     the-global-environment
;; ambeval success
                     (lambda (val next-alternative)
                       (announce-output output-prompt)
                       (user-print val)
                       (internal-loop next-alternative))
;; ambeval failure
                     (lambda ()
                       (announce-output
                        ";;; There are no more values of")
                       (user-print input)
                       (driver-loop)))))))
  (internal-loop
   (lambda ()
     (newline)
     (display ";;; There is no current problem")
     (driver-loop))))

This is the C# implementation in all its glory. As you can see, there are two simple functions to handle the initial cross join, one function to serve as a filter, and one more to check for distinct values. All the power of a mighty ambiguous evaluator in a tiny little package.

static void Main(string[] args)
{
    const int b = 0;
    const int c = 1;
    const int f = 2;
    const int m = 3;
    const int s = 4;
    
    int[] baker = { 1, 2, 3, 4, 5 };
    int[] cooper = { 1, 2, 3, 4, 5 };
    int[] fletcher = { 1, 2, 3, 4, 5 };
    int[] miller = { 1, 2, 3, 4, 5 };
    int[] smith = { 1, 2, 3, 4, 5 };

    var source = baker.CrossJoin(cooper)
.CrossJoin(fletcher)
.CrossJoin(miller)
.CrossJoin(smith);
    var result = source.Require(x => x[b] != 5)
                      .Require(x => x[c] != 1)
                      .Require(x => x[f] != 5)
                      .Require(x => x[f] != 1)
                      .Require(x => x[m] > x[c])
                      .Require(x => Math.Abs(x[s] - x[f]) > 1)
                      .Require(x => Math.Abs(x[f] - x[c]) > 1)
                      .Require(x => IsDistinct(x));
    
    foreach (var x in result)
    {
        Console.WriteLine("{ Baker:" + x[b] + " Cooper:" + x[c] + 
" Fletcher" + x[f] + " Miller:" + x[m]
+ " Smith" + x[s] + "}"); } } public static bool IsDistinct(params int[] source) { HashSet<int> temp = new HashSet<int>(source); return temp.Count == source.Count(); } static IEnumerable<T> Require<T>(this IEnumerable<T> source, Predicate<T> predicate) { foreach (T item in source) { if (predicate(item)) yield return item; } } static IEnumerable<T[]> CrossJoin<T>(this IEnumerable<T> source1, IEnumerable<T> source2) { foreach (T itemA in source1) { foreach (T itemB in source2) { yield return new T[] { itemA, itemB }; } } } static IEnumerable<T[]> CrossJoin<T>(this IEnumerable<T[]> source1, IEnumerable<T> source2) { foreach (T[] itemA in source1) { foreach (T itemB in source2) { var temp = itemA.ToList(); temp.Add(itemB); yield return temp.ToArray(); } } }
And for completeness, here is the LINQ solution in VB.
Dim baker = L(1, 2, 3, 4, 5)
Dim cooper = L(1, 2, 3, 4, 5)
Dim fletcher = L(1, 2, 3, 4, 5)
Dim miller = L(1, 2, 3, 4, 5)
Dim smith = L(1, 2, 3, 4, 5)

Dim sample = From b In baker _
    From c In cooper _
    From f In fletcher _
    From m In miller _
    From s In smith _
        Select b, c, f, m, s

Dim query = From row In sample _
Where IsDistinct(row.b, row.c, row.f, row.m, row.s) _ Where row.b <> 5 _ Where row.c <> 1 _ Where row.f <> 5 _ Where row.f <> 1 _ Where row.m > row.c _ Where Math.Abs(row.s - row.f) <> 1 _ Where Math.Abs(row.f - row.c) <> 1 For Each row In query Console.WriteLine() Console.WriteLine("Baker : " & row.b) Console.WriteLine("Cooper : " & row.c) Console.WriteLine("Fletcher : " & row.f) Console.WriteLine("Miller : " & row.m) Console.WriteLine("Smith : " & row.s) Next

Advertisements

1 Comment »

  1. SICP is about learning concepts, not learning Scheme. This part introduces the idea of “continuation”, by showing how to implement it rather than how to use the call/cc function provided by Scheme (because it’s a more effective way to learn.)

    Otherwise, amb could just be defined as :

    (define (amb-backtrack)
    (error “no solution found”))

    (define (amb . args)
    (call/cc (lambda (return)
    (let ((backtrack amb-backtrack))
    (map (lambda (x)
    (call/cc (lambda (k)
    (set! amb-backtrack k)
    (return x))))
    args)
    (backtrack ‘fail)))))

    (I’ve removed the macro noise, but you might want to look at http://www.ccs.neu.edu/home/dorai/t-y-scheme/t-y-scheme-Z-H-16.html#node_sec_14.2 )

    If you really want to “challenge SICP”, try rewriting your code without using a specialised application of continuation in your code (ie, no yield and no already-implemented IEnumerable instance). I guess it would be much longer.

    Comment by lasts — June 20, 2009 @ 1:16 pm


RSS feed for comments on this post. TrackBack URI

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Blog at WordPress.com.

%d bloggers like this: