suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Danny Yoo 2011-11-09 16:23:27 -05:00
parent 17b9d0b19b
commit 78737142d0
6 changed files with 116 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
cs019/cs019.rkt
View File

@ -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
@ -71,6 +87,8 @@
string-upper-case?
string-lower-case?)
(require "lists.rkt")
(provide (all-from-out "lists.rkt"))
(require "../image.rkt")
(provide (all-from-out "../image.rkt"))

64
cs019/lists.rkt Normal file
View File

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

2
tests/more-tests/lists-cs019.expected Normal file
View File

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

19
tests/more-tests/lists-cs019.rkt Normal file
View File

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

1
tests/run-more-tests.rkt
View File

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

2
version.rkt
View File

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