correcting implementation of cs019 list selectors, since they want to deal with shared structures

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"))
+                      (except-out (all-from-out "../lang/whalesong.rkt")
-                     if
+                                  
-                     cond
+                                  whalesong:if
-                     case
+                                  whalesong:cond
-                     member
+                                  whalesong:case
-                     define
+                                  whalesong:member
-                     lambda
+                                  whalesong:define
-                     unless
+                                  whalesong:lambda
-                     when
+                                  whalesong:unless
-                     local)
+                                  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"))

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]])

tests/more-tests/lists-cs019.expected

@@ -0,0 +1,2 @@
+Running tests...
+All 10 tests passed!

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)
+

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")

version.rkt

@@ -6,4 +6,4 @@
 
 (provide version)
 (: version String)
-(define version "1.76")
+(define version "1.78")