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

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

@ -152,6 +152,52 @@
(let ((current-window (open-viewport "Canvas" WIDTH HEIGHT))
(*delta* 0))
(set! @vp current-window)
(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 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 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 current-window) w) #t))
(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
@ -184,51 +230,23 @@
(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))))
(get-mouse-click current-window))))
(set! %get-key-event
(lambda ()
(cond
[(ready-key-press @vp) => key-value]
[(ready-key-press current-window) => key-value]
[else false])))
(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))
(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)))
(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))
(set! %end-of-time (lambda () ((stop-tick @vp))))
(set! %get-mouse-event
(lambda ()
(cond
[(ready-mouse-click @vp) => mouse-click-posn]
[(ready-mouse-click current-window) => mouse-click-posn]
[else false])))
#t))
#t)
(define (stop)
(close-graphics)
@ -256,8 +274,6 @@
(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)
@ -272,7 +288,7 @@
(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^)

12
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
@ -33,19 +34,20 @@
(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)))
(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)