np/scheme-for-kids
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Add README.org. Fix indentations

Browse Source
This commit is contained in:
Nikolay Puzanov 2014-04-18 10:48:33 +04:00
parent 22e44c9663
commit 7a703874a4
2 changed files with 170 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
kot-kit.scm
View File

@ -1,3 +1,22 @@
;; Copyright (c) 2014 Nikolay Puzanov <punzik@gmail.com>
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;; THE SOFTWARE.
(import (rnrs io ports (6))) ;; Guile (import (rnrs io ports (6))) ;; Guile
;;(require rnrs/io/ports-6) ;; Racket ;;(require rnrs/io/ports-6) ;; Racket
@ -68,5 +87,3 @@
(call-with-output-file TREE-FILE-NAME (lambda (p) (write tree p))) (call-with-output-file TREE-FILE-NAME (lambda (p) (write tree p)))
)))) ))))
;; vim: set ts=2 sts=2 sw=2 expandtab:

284
turtle.rkt
View File

@ -1,4 +1,24 @@
;; Copyright (c) 2014 Nikolay Puzanov <punzik@gmail.com>
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;; THE SOFTWARE.
#lang racket/gui #lang racket/gui
(require racket/gui/base) (require racket/gui/base)
(define grid-step 20) (define grid-step 20)
@ -20,168 +40,166 @@
(define canvas (new canvas% [parent frame] (define canvas (new canvas% [parent frame]
[paint-callback [paint-callback
(λ (canvas dc) (λ (canvas dc)
(send dc set-smoothing 'unsmoothed) (send dc set-smoothing 'unsmoothed)
(send dc set-pen "gray" 1 'solid) (send dc set-pen "gray" 1 'solid)
(let-values (((w h) (send canvas get-size))) (let-values (((w h) (send canvas get-size)))
(begin (begin
(do ((x 0 (+ x grid-step))) ((>= x w) #t) (do ((x 0 (+ x grid-step))) ((>= x w) #t)
(send dc draw-line x 0 x h)) (send dc draw-line x 0 x h))
(do ((y 0 (+ y grid-step))) ((>= y h) #t) (do ((y 0 (+ y grid-step))) ((>= y h) #t)
(send dc draw-line 0 y w y)))) (send dc draw-line 0 y w y))))
(send dc set-smoothing 'smoothed) (send dc set-smoothing 'smoothed)
(send dc set-pen "blue" 2 'solid) (send dc set-pen "blue" 2 'solid)
(send dc set-brush "blue" 'transparent) (send dc set-brush "blue" 'transparent)
(send dc draw-ellipse (send dc draw-ellipse
(- (* grid-step zero-x) 4) (- (* grid-step zero-x) 4)
(- (* grid-step zero-y) 4) (- (* grid-step zero-y) 4)
8 8) 8 8)
(let ((points (map (λ (pt) (let ((points (map (λ (pt)
(point (point-draw pt) (point (point-draw pt)
(* grid-step (+ zero-x (point-x pt))) (* grid-step (+ zero-x (point-x pt)))
(* grid-step (+ zero-y (point-y pt))))) (* grid-step (+ zero-y (point-y pt)))))
poly))) poly)))
(let loop ((pt0 (car points)) (let loop ((pt0 (car points))
(points (cdr points))) (points (cdr points)))
(if (null? points) (if (null? points)
#f #f
(let ((pt (car points))) (let ((pt (car points)))
(begin (begin
(if (point-draw pt0) (if (point-draw pt0)
(send dc draw-line (send dc draw-line
(point-x pt0) (point-x pt0)
(point-y pt0) (point-y pt0)
(point-x pt) (point-x pt)
(point-y pt)) (point-y pt))
#f) #f)
(loop pt (cdr points))))))) (loop pt (cdr points)))))))
(send dc set-brush "blue" (if draw 'solid 'transparent)) (send dc set-brush "blue" (if draw 'solid 'transparent))
(let* ((last-pt (car poly)) (let* ((last-pt (car poly))
(last-pt-x (* grid-step (+ zero-x (point-x last-pt)))) (last-pt-x (* grid-step (+ zero-x (point-x last-pt))))
(last-pt-y (* grid-step (+ zero-y (point-y last-pt))))) (last-pt-y (* grid-step (+ zero-y (point-y last-pt)))))
(send dc draw-rectangle (- last-pt-x 4) (- last-pt-y 4) 8 8)))])) (send dc draw-rectangle (- last-pt-x 4) (- last-pt-y 4) 8 8)))]))
(define (parse-commands str) (define (parse-commands str)
(if (= (string-length str) 0) (if (= (string-length str) 0)
(cons 0 0) (cons 0 0)
(let parse ((cmds (string-split str)) (let parse ((cmds (string-split str))
(x 0) (x 0)
(y 0)) (y 0))
(if (null? cmds) (if (null? cmds)
(cons x y) (cons x y)
(let* ((cmd (string-upcase (car cmds))) (let* ((cmd (string-upcase (car cmds)))
(cmd-char (string-ref cmd 0)) (cmd-char (string-ref cmd 0))
(cmds-tail (cdr cmds)) (cmds-tail (cdr cmds))
(argument (λ (dx dy) (argument (λ (dx dy)
(if (null? cmds-tail) (if (null? cmds-tail)
(begin (begin
(printf "Need argument for '~a'\n" cmd) (printf "Need argument for '~a'\n" cmd)
(parse cmds-tail x y)) (parse cmds-tail x y))
(let ((val (string->number (car cmds-tail)))) (let ((val (string->number (car cmds-tail))))
(if (equal? val #f) (if (equal? val #f)
(begin (begin
(printf "'~a' is not valid argument for '~a'\n" (car cmds-tail) cmd) (printf "'~a' is not valid argument for '~a'\n" (car cmds-tail) cmd)
(parse cmds-tail x y)) (parse cmds-tail x y))
(parse (cdr cmds-tail) (parse (cdr cmds-tail)
(+ x (* val dx)) (+ x (* val dx))
(+ y (* val dy))))))))) (+ y (* val dy)))))))))
(cond (cond
((or (equal? cmd "EXIT") ((or (equal? cmd "EXIT")
(equal? cmd-char #\Q)) 'quit) (equal? cmd-char #\Q)) 'quit)
((equal? cmd-char #\L) (argument -1 0)) ((equal? cmd-char #\L) (argument -1 0))
((equal? cmd-char #\R) (argument 1 0)) ((equal? cmd-char #\R) (argument 1 0))
((equal? cmd-char #\U) (argument 0 -1)) ((equal? cmd-char #\U) (argument 0 -1))
((equal? cmd-char #\D) (argument 0 1)) ((equal? cmd-char #\D) (argument 0 1))
((equal? cmd-char #\C) 'clear) ((equal? cmd-char #\C) 'clear)
((equal? cmd-char #\P) 'pen) ((equal? cmd-char #\P) 'pen)
((equal? cmd-char #\S) 'save) ((equal? cmd-char #\S) 'save)
((equal? cmd-char #\B) 'back) ((equal? cmd-char #\B) 'back)
(else (else
(begin (begin
(printf "Unknown command '~a'\n" cmd) (printf "Unknown command '~a'\n" cmd)
(cons 0 0))))))))) (cons 0 0)))))))))
(define (process poly port interactive) (define (process poly port interactive)
(let ((cmd-line (begin (let ((cmd-line (begin
(if interactive (if interactive
(display ">> ") (display ">> ")
#f) #f)
(read-line port)))) (read-line port))))
(if (eof-object? cmd-line) (if (eof-object? cmd-line)
#f #f
(let ((ret (parse-commands cmd-line))) (let ((ret (parse-commands cmd-line)))
(cond (cond
((equal? ret 'quit) #f) ((equal? ret 'quit) #f)
((equal? ret 'clear) (list (point #t 0 0))) ((equal? ret 'clear) (list (point #t 0 0)))
((equal? ret 'back) ((equal? ret 'back)
(if (> (length poly) 1) (if (> (length poly) 1)
(cdr poly) (cdr poly)
poly)) poly))
((equal? ret 'pen) ((equal? ret 'pen)
(begin (begin
(set! draw (not draw)) (set! draw (not draw))
poly)) poly))
((equal? ret 'save) ((equal? ret 'save)
(begin (begin
(call-with-output-file (if (equal? file-name #f) (call-with-output-file (if (equal? file-name #f)
default-file-name default-file-name
file-name) file-name)
(λ (port) (λ (port)
(foldr (lambda (pt pz) (foldr (lambda (pt pz)
(let ((dx (- (point-x pt) (point-x pz))) (let ((dx (- (point-x pt) (point-x pz)))
(dy (- (point-y pt) (point-y pz)))) (dy (- (point-y pt) (point-y pz))))
(begin (begin
(if (not (eq? (point-draw pt) (point-draw pz))) (if (not (eq? (point-draw pt) (point-draw pz)))
(fprintf port "pen\n") (fprintf port "pen\n")
#f) #f)
(if (not (= dx 0)) (if (not (= dx 0))
(if (> dx 0) (if (> dx 0)
(fprintf port "right ~a " dx) (fprintf port "right ~a " dx)
(fprintf port "left ~a " (- dx))) (fprintf port "left ~a " (- dx)))
#f) #f)
(if (not (= dy 0)) (if (not (= dy 0))
(if (> dy 0) (if (> dy 0)
(fprintf port "down ~a " dy) (fprintf port "down ~a " dy)
(fprintf port "up ~a " (- dy))) (fprintf port "up ~a " (- dy)))
#f) #f)
(newline port)) (newline port))
pt)) pt))
(point #t 0 0) poly)) (point #t 0 0) poly))
#:exists 'truncate) #:exists 'truncate)
poly)) poly))
(else (else
(let ((dx (car ret)) (let ((dx (car ret))
(dy (cdr ret)) (dy (cdr ret))
(prev-x (point-x (car poly))) (prev-x (point-x (car poly)))
(prev-y (point-y (car poly)))) (prev-y (point-y (car poly))))
(if (and (= dx 0) (= dy 0)) (if (and (= dx 0) (= dy 0))
poly poly
(cons (point draw (+ prev-x dx) (+ prev-y dy)) poly))))))))) (cons (point draw (+ prev-x dx) (+ prev-y dy)) poly)))))))))
(define file-name (define file-name
(if (= (vector-length (current-command-line-arguments)) 0) (if (= (vector-length (current-command-line-arguments)) 0)
#f #f
(vector-ref (current-command-line-arguments) 0))) (vector-ref (current-command-line-arguments) 0)))
(send frame show #t) (send frame show #t)
(thread (λ () (thread (λ ()
(let ((func (λ (port interactive) (let ((func (λ (port interactive)
(begin (begin
(let loop () (let loop ()
(let ((ret (process poly port interactive))) (let ((ret (process poly port interactive)))
(if (equal? ret #f) (if (equal? ret #f)
#f #f
(begin (begin
(set! poly ret) (set! poly ret)
(send canvas refresh) (send canvas refresh)
(loop))))))))) (loop)))))))))
(if (not (equal? file-name #f)) (if (not (equal? file-name #f))
(if (file-exists? file-name) (if (file-exists? file-name)
(call-with-input-file file-name (call-with-input-file file-name
(λ (port) (func port #f))) #f) #f) (λ (port) (func port #f))) #f) #f)
(func (current-input-port) #t)) (func (current-input-port) #t))
(send frame show #f))) (send frame show #f)))
; vim: set ts=2 sts=2 sw=2 expandtab: