From 78737142d0853e995fa4c0c2a13a0b3634b30d1b Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Wed, 9 Nov 2011 16:23:27 -0500
Subject: [PATCH] correcting implementation of cs019 list selectors, since they
 want to deal with shared structures

---
 cs019/cs019.rkt                       | 40 ++++++++++++-----
 cs019/lists.rkt                       | 64 +++++++++++++++++++++++++++
 tests/more-tests/lists-cs019.expected |  2 +
 tests/more-tests/lists-cs019.rkt      | 19 ++++++++
 tests/run-more-tests.rkt              |  1 +
 version.rkt                           |  2 +-
 6 files changed, 116 insertions(+), 12 deletions(-)
 create mode 100644 cs019/lists.rkt
 create mode 100644 tests/more-tests/lists-cs019.expected
 create mode 100644 tests/more-tests/lists-cs019.rkt

diff --git a/cs019/cs019.rkt b/cs019/cs019.rkt
index 0bbd527..5c3a0d8 100644
--- a/cs019/cs019.rkt
+++ b/cs019/cs019.rkt
@@ -9,6 +9,8 @@
 
 
 (require "cs019-pre-base.rkt")
+
+
 (provide (rename-out [cs019-lambda lambda]
                      [cs019-define define]
                      [cs019-when when]
@@ -48,16 +50,30 @@
                            real-name]
                           [else
                            #f]))
-                      (all-from-out "../lang/whalesong.rkt"))
-                     if
-                     cond
-                     case
-                     member
-                     define
-                     lambda
-                     unless
-                     when
-                     local)
+                      (except-out (all-from-out "../lang/whalesong.rkt")
+                                  
+                                  whalesong:if
+                                  whalesong:cond
+                                  whalesong:case
+                                  whalesong:member
+                                  whalesong:define
+                                  whalesong:lambda
+                                  whalesong:unless
+                                  whalesong:when
+                                  whalesong:local
+
+
+                                  whalesong:first
+                                  whalesong:rest
+                                  whalesong:second
+                                  whalesong:third
+                                  whalesong:fourth
+                                  whalesong:fifth
+                                  whalesong:sixth
+                                  whalesong:seventh
+                                  whalesong:eighth
+                                  whalesong:ninth
+                                  )))
 
          string-ith
          replicate
@@ -70,7 +86,9 @@
          string-whitespace?
          string-upper-case?
          string-lower-case?)
-                     
+
+(require "lists.rkt")
+(provide (all-from-out "lists.rkt"))
 
 (require "../image.rkt")
 (provide (all-from-out "../image.rkt"))
diff --git a/cs019/lists.rkt b/cs019/lists.rkt
new file mode 100644
index 0000000..165e7f5
--- /dev/null
+++ b/cs019/lists.rkt
@@ -0,0 +1,64 @@
+#lang planet dyoo/whalesong/base
+#|
+Why on earth are these here?
+Because first, etc. don't work on cyclic lists:
+(define web-colors
+ (shared ([W (cons "white" G)]
+          [G (cons "grey" W)])
+   W))
+(first web-colors)
+fails with expected argument of type <list>.
+But car/cdr still do the trick per email from mflatt, 10/20/2011.
+
+So we suppress the built-in functions from lang/htdp-advanced
+and provide these instead.
+|#
+
+(require (for-syntax racket/base))
+
+(provide first second third fourth fifth sixth seventh eighth ninth
+         rest)
+
+
+(define (rest x)
+  (cond
+   [(pair? x)
+    (cdr x)]
+   [else
+    (raise-type-error 'rest
+                      "list with at least one element"
+                      x)]))
+
+(define-syntax (define-list-selectors stx)
+  (syntax-case stx ()
+    [(_ [(name ordinal) ...])
+     (with-syntax ([(offset ...)
+                    (build-list (length (syntax->list #'(name ...)))
+                                (lambda (i) i))])
+       #'(begin
+           (define (name p)
+             (pair-ref p offset 'name 'ordinal p))
+           ...))]))
+
+(define (pair-ref x offset name ordinal original)
+  (cond
+   [(pair? x)
+    (cond
+     [(= offset 0)
+      (car x)]
+     [else
+      (pair-ref (cdr x) (sub1 offset) name ordinal original)])]
+   [else
+    (raise-type-error name
+                      (format "list with ~a elements" ordinal)
+                      original)]))
+                                           
+(define-list-selectors [[first one]
+                        [second two]
+                        [third three]
+                        [fourth four]
+                        [fifth five]
+                        [sixth six]
+                        [seventh seven]
+                        [eighth eight]
+                        [ninth nine]])
diff --git a/tests/more-tests/lists-cs019.expected b/tests/more-tests/lists-cs019.expected
new file mode 100644
index 0000000..a4d23ae
--- /dev/null
+++ b/tests/more-tests/lists-cs019.expected
@@ -0,0 +1,2 @@
+Running tests...
+All 10 tests passed!
diff --git a/tests/more-tests/lists-cs019.rkt b/tests/more-tests/lists-cs019.rkt
new file mode 100644
index 0000000..012b3f5
--- /dev/null
+++ b/tests/more-tests/lists-cs019.rkt
@@ -0,0 +1,19 @@
+#lang planet dyoo/whalesong/cs019
+
+(define web-colors
+ (shared ([W (cons "white" G)]
+          [G (cons "grey" W)])
+   W))
+
+(check-expect (first web-colors) "white")
+(check-expect (second web-colors) "grey")
+(check-expect (third web-colors) "white")
+(check-expect (fourth web-colors) "grey")
+(check-expect (fifth web-colors) "white")
+(check-expect (sixth web-colors) "grey")
+(check-expect (seventh web-colors) "white")
+(check-expect (eighth web-colors) "grey")
+
+(check-expect (equal? (rest web-colors) (rest (rest (rest web-colors)))) true)
+(check-expect (eq? (rest web-colors) (rest (rest (rest web-colors)))) true)
+
diff --git a/tests/run-more-tests.rkt b/tests/run-more-tests.rkt
index 8ce86cb..5c0bc7e 100644
--- a/tests/run-more-tests.rkt
+++ b/tests/run-more-tests.rkt
@@ -40,3 +40,4 @@
 (test "more-tests/sharing-cs019.rkt")
 (test "more-tests/basics-cs019.rkt")
 (test "more-tests/sigs-cs019.rkt")
+(test "more-tests/lists-cs019.rkt")
diff --git a/version.rkt b/version.rkt
index edc0518..43f8469 100644
--- a/version.rkt
+++ b/version.rkt
@@ -6,4 +6,4 @@
 
 (provide version)
 (: version String)
-(define version "1.76")
+(define version "1.78")