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

fixed dir, path->string

Browse Source 
svn: r2502
This commit is contained in:
Matthias Felleisen 2006-03-25 03:18:08 +00:00
parent dba28564ea
commit 5d41b105e0
5 changed files with 126 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/htdp/Test/dir.ss
View File

@ -9,7 +9,7 @@
(append
(map (lambda (x) (format "in Teachpacks, not in Test: ~s" x))
(filter (lambda (x) (boolean? (member x current-files))) teachps-files))
(filter (lambda (x) (not (member x current-files))) teachps-files))
(map (lambda (x) (format "in Test, not in Teachpacks: ~s" x))
(filter (lambda (x) (boolean? (member x teachps-files))) current-files)))
(filter (lambda (x) (not (member x teachps-files))) current-files)))

204
collects/htdp/big-draw.ss
View File

@ -1,21 +1,21 @@
#cs
(module big-draw mzscheme
(require "error.ss"
"draw-sig.ss"
(lib "etc.ss")
(lib "posn.ss" "lang")
(lib "prim.ss" "lang")
(lib "unitsig.ss")
(prefix mred: (lib "mred.ss" "mred"))
(lib "class.ss")
(lib "mred-sig.ss" "mred")
(lib "graphics-sig.ss" "graphics")
(lib "graphics-posn-less-unit.ss" "graphics"))
"draw-sig.ss"
(lib "etc.ss")
(lib "posn.ss" "lang")
(lib "prim.ss" "lang")
(lib "unitsig.ss")
(prefix mred: (lib "mred.ss" "mred"))
(lib "class.ss")
(lib "mred-sig.ss" "mred")
(lib "graphics-sig.ss" "graphics")
(lib "graphics-posn-less-unit.ss" "graphics"))
(define-values/invoke-unit/sig graphics:posn-less^
graphics-posn-less@ #f
(mred : mred^)
graphics:posn^)
graphics-posn-less@ #f
(mred : mred^)
graphics:posn^)
(provide-signature-elements graphics:posn-less^)
@ -55,7 +55,7 @@
[proc (fools (format "~a/proc" stuff))])
#`(define-values (#,%name #,proc)
(values the-error
(lambda a (apply #,%name a)))))]))
(lambda a (apply #,%name a)))))]))
(define-syntax (define-hook-draw/clear stx)
(syntax-case stx ()
@ -152,83 +152,101 @@
(let ((current-window (open-viewport "Canvas" WIDTH HEIGHT))
(*delta* 0))
(set! @vp current-window)
(set! %clear-all (clear-viewport current-window))
(set! %draw-solid-line
(make-line 'draw-solid-line (draw-line current-window)))
(set! %clear-solid-line
(make-line 'clear-solid-line
(lambda (p1 p2 c)
((clear-line current-window) p1 p2))))
(set! %draw-solid-rect (make-rect 'draw-solid-rect (draw-solid-rectangle current-window)))
(set! %clear-solid-rect
(make-rect 'clear-solid-rect
(lambda (p w h c)
((clear-solid-rectangle current-window) p w h))))
(set! %draw-solid-disk (make-circle 'draw-solid-disk (draw-solid-ellipse current-window)))
(set! %clear-solid-disk
(make-circle 'clear-solid-disk
(lambda (p r1 r2 c)
((clear-solid-ellipse current-window) p r1 r2))))
(set! %draw-circle (make-circle 'draw-circle (draw-ellipse current-window)))
(set! %clear-circle
(make-circle 'clear-circle
(lambda (p r1 r2 c)
((clear-ellipse current-window) p r1 r2))))
(set! %draw-string (make-%string 'draw-string (draw-string current-window)))
(set! %clear-string (make-%string 'clear-string (clear-string current-window)))
(set! %wait-for-mouse-click
(lambda ()
(mouse-click-posn
(get-mouse-click @vp))))
(set! %get-key-event
(lambda ()
(cond
[(ready-key-press @vp) => key-value]
[else false])))
(set! @pm (open-pixmap "Canvas" WIDTH HEIGHT))
(set-draw-ops current-window)
(set! %on-key-event
(lambda (f)
(check-proc 'on-key-event f 2 'first 'two)
((set-on-key-event @vp)
(lambda (x y) (f (key-value x) y)))
#t))
(lambda (f)
(check-proc 'on-key-event f 2 'first 'two)
((set-on-key-event current-window)
(lambda (x y) (f (key-value x) y)))
#t))
(set! %on-tick-event
(lambda (f)
(let* ([w (ceiling (* 1000 *delta*))]
[w (if (exact? w) w (inexact->exact w))])
(check-proc 'on-key-event f 1 'first 'one)
((set-on-tick-event @vp) w f)
#t)))
(lambda (f)
(let* ([w (ceiling (* 1000 *delta*))]
[w (if (exact? w) w (inexact->exact w))])
(check-proc 'on-key-event f 1 'first 'one)
((set-on-tick-event current-window) w
(lambda (x) (f x)))
#t)))
(set! %big-bang
(lambda (delta w)
(check-arg 'big-bang
(and (number? delta) (>= delta 0))
"number [of seconds] between 0 and 1000000"
"first"
delta)
(set! *delta* delta)
((init-world @vp) w) #t))
(lambda (delta w)
(check-arg 'big-bang
(and (number? delta) (>= delta 0))
"number [of seconds] between 0 and 1000000"
"first"
delta)
(set! *delta* delta)
((init-world current-window) w) #t))
(set! %end-of-time (lambda () ((stop-tick @vp))))
(set! %get-mouse-event
(lambda ()
(cond
[(ready-mouse-click @vp) => mouse-click-posn]
[else false])))
(set! %end-of-time (lambda () ((stop-tick current-window))))
#t))
(define @pm #f)
(define (begin-draw-sequence width height)
(check-arg 'start (and (integer? width) (> width 0)) "positive integer" "first" width)
(check-arg 'start (and (integer? height) (> height 0)) "positive integer" "second" height)
([draw-rectangle @pm] (make-posn 0 0) width height "white")
(set-draw-ops @pm)
#t)
(define (end-draw-sequence)
(copy-viewport @pm @vp)
(set-draw-ops @vp)
#t)
(define (set-draw-ops current-window)
(set! %clear-all (clear-viewport current-window))
(set! %draw-solid-line
(make-line 'draw-solid-line (draw-line current-window)))
(set! %clear-solid-line
(make-line 'clear-solid-line
(lambda (p1 p2 c)
((clear-line current-window) p1 p2))))
(set! %draw-solid-rect (make-rect 'draw-solid-rect (draw-solid-rectangle current-window)))
(set! %clear-solid-rect
(make-rect 'clear-solid-rect
(lambda (p w h c)
((clear-solid-rectangle current-window) p w h))))
(set! %draw-solid-disk (make-circle 'draw-solid-disk (draw-solid-ellipse current-window)))
(set! %clear-solid-disk
(make-circle 'clear-solid-disk
(lambda (p r1 r2 c)
((clear-solid-ellipse current-window) p r1 r2))))
(set! %draw-circle (make-circle 'draw-circle (draw-ellipse current-window)))
(set! %clear-circle
(make-circle 'clear-circle
(lambda (p r1 r2 c)
((clear-ellipse current-window) p r1 r2))))
(set! %draw-string (make-%string 'draw-string (draw-string current-window)))
(set! %clear-string (make-%string 'clear-string (clear-string current-window)))
(set! %wait-for-mouse-click
(lambda ()
(mouse-click-posn
(get-mouse-click current-window))))
(set! %get-key-event
(lambda ()
(cond
[(ready-key-press current-window) => key-value]
[else false])))
(set! %get-mouse-event
(lambda ()
(cond
[(ready-mouse-click current-window) => mouse-click-posn]
[else false])))
#t)
(define (stop)
(close-graphics)
@ -256,23 +274,21 @@
(set! %get-mouse-event the-error)
#t)
;; start/cartesian-plane : Number Number -> true
;; start up a canvas of size width x height and draw a centered cartesian coordinate
(define (start/cartesian-plane width height)
(check-arg 'start/cartesian-plane
(and (integer? width) (> width 0)) "positive integer" "first" width)
(and (integer? width) (> width 0)) "positive integer" "first" width)
(check-arg 'start/cartesian-plane
(and (integer? height) (> height 0)) "positive integer" "second" height)
(and (integer? height) (> height 0)) "positive integer" "second" height)
(local ((define trash (start width height))
(define mid-x (quotient width 2))
(define mid-y (quotient height 2)))
(and (draw-solid-line (make-posn mid-x 0) (make-posn mid-x height))
(draw-solid-line (make-posn 0 mid-y) (make-posn width mid-y)))))
(draw-solid-line (make-posn 0 mid-y) (make-posn width mid-y)))))
(define @vp #f)
#cs(define (get-@VP) @vp)
(define (get-@VP) @vp)
(provide-signature-elements draw^)
@ -288,7 +304,7 @@
((blue) (make-rgb 0 0 1.0))
((black) (make-rgb 0 0 0))
(else
(let ([x (send mred:the-color-database find-color (symbol->string s))])
(if (rgb? x)
x
(error 'draw.ss "The symbol ~e is not a legal color in draw.ss." s)))))))
(let ([x (send mred:the-color-database find-color (symbol->string s))])
(if (rgb? x)
x
(error 'draw.ss "The symbol ~e is not a legal color in draw.ss." s)))))))

14
collects/htdp/dir.ss
View File

@ -1,6 +1,7 @@
#cs(module dir mzscheme
(require (lib "error.ss" "htdp")
(lib "list.ss")
(lib "etc.ss")
(lib "prim.ss" "lang"))
(provide
@ -32,20 +33,21 @@
;; File = (make-file Symbol Number (union '() X))
(define (create-dir/proc a-path)
(check-arg 'create-dir (string? a-path) "string" "first" a-path)
(if (directory-exists? a-path)
(car (explore (list a-path)))
(error 'create-dir "not a directory: ~e" a-path)))
(check-arg 'create-dir (string? a-path) "string" "first" a-path)
(let ([a-path! (string->path a-path)])
(if (directory-exists? a-path!)
(car (explore (list a-path!)))
(error 'create-dir "not a directory: ~e" a-path))))
;; explore : (listof String[directory-names]) -> (listof Directory)
(define (explore dirs)
(map (lambda (d)
(let-values ([(fs ds) (pushd d directory-files&directories)])
(make-dir
(string->symbol (my-split-path d))
(string->symbol (path->string (my-split-path d)))
(explore (map (lambda (x) (build-path d x)) ds))
(map make-file
(map string->symbol fs)
(map (compose string->symbol path->string) fs)
(map (lambda (x) (if (file-exists? x) (file-size x) 0))
(map (lambda (x) (build-path d x)) fs))
(map (lambda (x) (if (link-exists? x) 'link null)) fs)))))

6
collects/htdp/draw-sig.ss
View File

@ -19,7 +19,11 @@
wait-for-mouse-click ; -> posn
get-key-event ; -> (union #f char symbol)
get-mouse-event ; -> (union #f posn)
get-@VP
;;
get-@VP ; -> Viewport
begin-draw-sequence ; Nat Nat -> #t
end-draw-sequence ; -> #t
;;
big-bang ; World -> true
on-key-event ; (union char symbol) World -> World
on-tick-event ; World -> World

2
collects/htdp/world.ss
View File

@ -169,7 +169,7 @@
(label "DrScheme")
(stretchable-width #f)
(stretchable-height #f)
(style '(no-resize-border))))
(style '(no-resize-border metal))))
(let ([c (new (class editor-canvas%
(super-new)
(define/override (on-char e)