;Copyright 2002 Mike MacHenry ;This program is free software; you can redistribute it and/or modify ;it under the terms of the GNU General Public License as published by ;the Free Software Foundation; either version 2 of the License, or ;(at your option) any later version. ;This program is distributed in the hope that it will be useful, ;but WITHOUT ANY WARRANTY; without even the implied warranty of ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;GNU General Public License for more details. ;You should have received a copy of the GNU General Public License ;along with this program; if not, write to the Free Software ;Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;The license is at . ;sneaker.ss v0.2.0 ;dskippy 2002/02/07 ;Mike MacHenry ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; "leave it to guys to write a computer program to do what women ;; do in their heads everyday" - Jessica Marshall 2002/01/21 ;; ;; This program is a scheme rewrite of "The sneaker program" writen ;; by Mike Burns. It was written to be contributed the ever growing ;; collections of rewrites of his program which sadly does not contain ;; a scheme version. Also I wish to contribute a version with a ;; function I think would be cool which is different probabilities ;; based on color so for example the random sneakers could be pushed ;; towards green and red on christmas. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-struct holiday (month day sneakers)) ;; ::= (list ... ) ;; ::= Symbol ;; ::= (cons ) ;; ::= 'left ;; ::= 'right ;; ::= (make-holiday Number Number ) (define *sneakers* '(red orange yellow green blue khaki black)) (define *holidays* (list (make-holiday 12 25 '(red green)) (make-holiday 10 31 '(orange black)) (make-holiday 7 4 '(red white blue)))) (define *retries-on-matching-pair* 1) (define *favoritism-for-holiday-colors* 5) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;get-sneakers: -> ;;the sneaker set for the given date (define get-sneakers (lambda (date) (letrec ;;get-favored: (list-of ) -> ;;the sneakers to favor for this date ((get-favored (lambda (holidays) (cond ((null? holidays) '()) ((and (eq? (holiday-day (car holidays)) (date-day date)) (eq? (holiday-month (car holidays)) (date-month date))) (holiday-sneakers (car holidays))) (else (get-favored (cdr holidays)))))) ;;extend: Number -> ;;add favorites to the sneakers n times (extend (lambda (sneakers favorites n) (cond ((zero? n) sneakers) (else (append favorites (extend sneakers favorites (sub1 n)))))))) (extend *sneakers* (get-favored *holidays*) *favoritism-for-holiday-colors*)))) ;;display-sneakers: -> (void) ;;displays the choices for the left and right sneaker (define display-sneakers (lambda (sp) (display (format "Left: ~s~%" (car sp))) (display (format "Right: ~s~%" (cdr sp))))) ;;get-pair: Date -> ;;the pair of sneakers that corresonds to the particular day (define get-pair (lambda (date) (letrec ((n-tries (lambda (n) (let* ((sneakers (get-sneakers date)) (left (random-sneaker sneakers)) (right (random-sneaker sneakers))) (if (or (zero? n) (not (eq? left right))) (cons left right) (n-tries (sub1 n))))))) (random-seed (+ (date-day date) (date-month date) (date-year date))) (n-tries *retries-on-matching-pair*)))) ;;random-sneaker: -> ;;a random sneaker from the sneaker-set (define random-sneaker (lambda (sneakers) (list-ref sneakers (random (length sneakers))))) ;;get-date: (Vector-of String) -> <#structure:date> ;;get the date passed on the command line or the current date (define get-date (lambda (date) (cond ((eq? (vector-length date) 3) (make-date 0 0 0 (string->number (vector-ref date 2)) (string->number (vector-ref date 1)) (string->number (vector-ref date 0)) 0 0 #f 0)) ((eq? (vector-length date) 0) (seconds->date (current-seconds))) (else (printf "Usage: sneaker.ss [year month day]~%") (exit 1))))) (display-sneakers (get-pair (get-date argv)))