From 158cc6ddf646b98afc8ba69ac58ed49117b760cc Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 18 Jan 2012 19:26:24 -0500 Subject: [PATCH] sierpenski carpet example --- examples/sierpinski-carpet.rkt | 39 ++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 examples/sierpinski-carpet.rkt diff --git a/examples/sierpinski-carpet.rkt b/examples/sierpinski-carpet.rkt new file mode 100644 index 0000000..cd9a436 --- /dev/null +++ b/examples/sierpinski-carpet.rkt @@ -0,0 +1,39 @@ +#lang planet dyoo/whalesong/base +(require (planet dyoo/whalesong/image)) +;; Sierpenski carpet. +;; http://rosettacode.org/wiki/Sierpinski_carpet#Scheme + +(define SQUARE (square 5 "solid" "red")) +(define SPACE (square 5 "solid" "white")) + +(define (carpet n) + (local [(define (in-carpet? x y) + (cond ((or (zero? x) (zero? y)) + #t) + ((and (= 1 (remainder x 3)) (= 1 (remainder y 3))) + #f) + (else + (in-carpet? (quotient x 3) (quotient y 3)))))] + + (letrec ([outer (lambda (i) + (cond + [(< i (expt 3 n)) + (local ([define a-row + (letrec ([inner + (lambda (j) + (cond [(< j (expt 3 n)) + (cons (if (in-carpet? i j) + SQUARE + SPACE) + (inner (add1 j)))] + [else + empty]))]) + (inner 0))]) + (cons (apply beside a-row) + (outer (add1 i))))] + [else + empty]))]) + (apply above (outer 0))))) + + +(carpet 4) \ No newline at end of file