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

Converting to scheme from mzscheme

Browse Source 
svn: r15281
This commit is contained in:
Jay McCarthy 2009-06-25 22:09:54 +00:00
parent 5b505d6f5c
commit a7256c91bf
7 changed files with 779 additions and 816 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
collects/frtime/date.ss
View File

@ -1,10 +1,9 @@
#lang scheme
(require "list.ss")
(require (rename-in (only-in "frtime.ss" provide)
[provide frtime:provide]))
(module date mzscheme (frtime:provide
(require "list.ss")
(require (rename "frtime.ss" frtime:provide provide))
(frtime:provide
(lifted date->string (lifted date->string
date-display-format date-display-format
find-seconds find-seconds
@ -13,42 +12,13 @@
julian/scalinger->string)) julian/scalinger->string))
;; Support for Julian calendar added by Shriram; ;; Support for Julian calendar added by Shriram;
;; current version only works until 2099 CE Gregorian ;; current version only works until 2099 CE Gregorian
#| (define legal-formats
(define-primitive seconds->date (num -> structure:date))
(define-primitive current-seconds (-> num))
(define-primitive date-second (structure:date -> num))
(define-primitive date-minute (structure:date -> num))
(define-primitive date-hour (structure:date -> num))
(define-primitive date-day (structure:date -> num))
(define-primitive date-month (structure:date -> num))
(define-primitive date-year (structure:date -> num))
(define-primitive date-week-day (structure:date -> num))
(define-primitive date-year-day (structure:date -> num))
(define-primitive date-dst? (structure:date -> bool))
(define-primitive make-date (num num num num num num num num bool ->
structure:date))
(define-primitive expr->string (a -> string))
(define-primitive foldl (case->
((a z -> z) z (listof a) -> z)
((a b z -> z) z (listof a) (listof b) -> z)
((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
(((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
(define-primitive foldr (case->
((a z -> z) z (listof a) -> z)
((a b z -> z) z (listof a) (listof b) -> z)
((a b c z -> z) z (listof a) (listof b) (listof c) -> z)
(((arglistof x) ->* z) z (listof (arglistof x)) ->* z)))
|#
(define legal-formats
(list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822)) (list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))
(define date-display-format (define date-display-format
(make-parameter 'american (make-parameter 'american
(lambda (s) (lambda (s)
(unless (memq s legal-formats) (unless (memq s legal-formats)
@ -57,7 +27,7 @@
s)) s))
s))) s)))
(define month/number->string (define month/number->string
(lambda (x) (lambda (x)
(case x (case x
[(12) "December"] [(1) "January"] [(2) "February"] [(12) "December"] [(1) "January"] [(2) "February"]
@ -66,7 +36,7 @@
[(9) "September"] [(10) "October"] [(11) "November"] [(9) "September"] [(10) "October"] [(11) "November"]
[else ""]))) [else ""])))
(define day/number->string (define day/number->string
(lambda (x) (lambda (x)
(case x (case x
[(0) "Sunday"] [(0) "Sunday"]
@ -78,7 +48,7 @@
[(6) "Saturday"] [(6) "Saturday"]
[else ""]))) [else ""])))
(define date->string (define date->string
(case-lambda (case-lambda
[(date) (date->string date #f)] [(date) (date->string date #f)]
[(date time?) [(date time?)
@ -176,16 +146,16 @@
(append day time) (append day time)
day))))])) day))))]))
(define leap-year? (define leap-year?
(lambda (year) (lambda (year)
(or (= 0 (modulo year 400)) (or (= 0 (modulo year 400))
(and (= 0 (modulo year 4)) (and (= 0 (modulo year 4))
(not (= 0 (modulo year 100))))))) (not (= 0 (modulo year 100)))))))
;; it's not clear what months mean in this context -- use days ;; it's not clear what months mean in this context -- use days
(define-struct date-offset (second minute hour day year)) (define-struct date-offset (second minute hour day year))
(define date- (define date-
(lambda (date1 date2) (lambda (date1 date2)
(let* ((second (- (date-second date1) (date-second date2))) (let* ((second (- (date-second date1) (date-second date2)))
(minute (+ (- (date-minute date1) (date-minute date2)) (minute (+ (- (date-minute date1) (date-minute date2))
@ -207,7 +177,7 @@
year)))) year))))
(define date-offset->string (define date-offset->string
(let ((first car) (let ((first car)
(second cadr)) (second cadr))
(case-lambda (case-lambda
@ -244,7 +214,7 @@
"" ""
non-zero-fields)]))]))) non-zero-fields)]))])))
(define days-per-month (define days-per-month
(lambda (year month) (lambda (year month)
(cond (cond
[(and (= month 2) (leap-year? year)) 29] [(and (= month 2) (leap-year? year)) 29]
@ -252,7 +222,7 @@
[(<= month 7) (+ 30 (modulo month 2))] [(<= month 7) (+ 30 (modulo month 2))]
[else (+ 30 (- 1 (modulo month 2)))]))) [else (+ 30 (- 1 (modulo month 2)))])))
(define find-extreme-date-seconds (define find-extreme-date-seconds
(lambda (start offset) (lambda (start offset)
(let/ec found (let/ec found
(letrec ([find-between (letrec ([find-between
@ -278,16 +248,16 @@
; succeeded; double offset again ; succeeded; double offset again
(loop hi (* 2 offset)))))))) (loop hi (* 2 offset))))))))
(define get-min-seconds (define get-min-seconds
(let ([d (delay (find-extreme-date-seconds (current-seconds) -1))]) (let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
(lambda () (lambda ()
(force d)))) (force d))))
(define get-max-seconds (define get-max-seconds
(let ([d (delay (find-extreme-date-seconds (current-seconds) 1))]) (let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
(lambda () (lambda ()
(force d)))) (force d))))
(define find-seconds (define find-seconds
(lambda (sec min hour day month year) (lambda (sec min hour day month year)
(let ([signal-error (let ([signal-error
(lambda (msg) (lambda (msg)
@ -327,12 +297,12 @@
[(eq? compare 'test-smaller) [(eq? compare 'test-smaller)
(loop secs (floor (/ (+ above-secs secs) 2)) above-secs)])))))) (loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
;; date->julian/scalinger : ;; date->julian/scalinger :
;; date -> number [julian-day] ;; date -> number [julian-day]
;; Note: This code is correct until 2099 CE Gregorian ;; Note: This code is correct until 2099 CE Gregorian
(define (date->julian/scalinger date) (define (date->julian/scalinger date)
(let ((day (date-day date)) (let ((day (date-day date))
(month (date-month date)) (month (date-month date))
(year (date-year date))) (year (date-year date)))
@ -364,10 +334,10 @@
gregorian-adjustment))) gregorian-adjustment)))
final-date))))))))))) final-date)))))))))))
;; julian/scalinger->string : ;; julian/scalinger->string :
;; number [julian-day] -> string [julian-day-format] ;; number [julian-day] -> string [julian-day-format]
(define (julian/scalinger->string julian-day) (define (julian/scalinger->string julian-day)
(apply string-append (apply string-append
(cons "JD " (cons "JD "
(reverse (reverse
@ -387,6 +357,3 @@
(cadr reversed-digits) (cadr reversed-digits)
(car reversed-digits))) (car reversed-digits)))
(loop (cdr (cdr (cdr reversed-digits)))))))))))) (loop (cdr (cdr (cdr reversed-digits))))))))))))
)

43
collects/frtime/frp-snip.ss
View File

@ -1,26 +1,28 @@
(module frp-snip mzscheme #lang scheme/base
(require mzlib/class (require scheme/class
mzlib/string (only-in mzlib/string expr->string)
mzlib/list scheme/list
mzlib/port scheme/port
framework framework
;; FRP requires ;; FRP requires
frtime/core/frp frtime/core/frp
(all-except frtime/lang-ext undefined?) (except-in frtime/lang-ext
(only frtime/lang-core any-nested-reactivity? raise-reactivity) undefined?)
(only-in frtime/lang-core
any-nested-reactivity? raise-reactivity)
;; MrEd require ;; MrEd require
(all-except mred send-event)) (except-in mred send-event))
(define drs-eventspace #f) (define drs-eventspace #f)
(define (set-eventspace evspc) (define (set-eventspace evspc)
(set! drs-eventspace evspc)) (set! drs-eventspace evspc))
(define value-snip-copy% (define value-snip-copy%
(class string-snip% (class string-snip%
(init-field current parent) (init-field current parent)
(inherit get-admin) (inherit get-admin)
@ -36,7 +38,7 @@
(send current draw dc x y left top right bottom dx dy draw-caret)) (send current draw dc x y left top right bottom dx dy draw-caret))
(super-instantiate (" ")))) (super-instantiate (" "))))
(define make-snip (define make-snip
(case-lambda (case-lambda
[(bhvr) [(bhvr)
(make-object string-snip% (make-object string-snip%
@ -52,7 +54,7 @@
[(bhvr super-render-fun) [(bhvr super-render-fun)
(get-rendering (value-now bhvr) super-render-fun)])) (get-rendering (value-now bhvr) super-render-fun)]))
(define value-snip% (define value-snip%
(class string-snip% (class string-snip%
(init-field bhvr) (init-field bhvr)
(field [copies empty] (field [copies empty]
@ -70,7 +72,7 @@
(super-instantiate (" ")))) (super-instantiate (" "))))
(define dynamic-snip-copy% (define dynamic-snip-copy%
(class editor-snip% (class editor-snip%
(init-field current parent) (init-field current parent)
(inherit get-editor) (inherit get-editor)
@ -95,7 +97,7 @@
[bottom-margin 0]) [bottom-margin 0])
(set-current current))) (set-current current)))
(define dynamic-snip% (define dynamic-snip%
(class snip% (class snip%
(init-field bhvr super-render-fun) (init-field bhvr super-render-fun)
@ -122,7 +124,7 @@
(super-new))) (super-new)))
(define (render beh as-snip?) (define (render beh as-snip?)
(cond (cond
[as-snip? (watch beh)] [as-snip? (watch beh)]
[(undefined? (value-now beh)) "<undefined>"] [(undefined? (value-now beh)) "<undefined>"]
@ -130,7 +132,7 @@
[(event? beh) (format "#<event (last: ~a)>" (event-set-events (signal-value beh)))] [(event? beh) (format "#<event (last: ~a)>" (event-set-events (signal-value beh)))]
[else beh])) [else beh]))
(define (render/dynamic-snip val super-render-fun) (define (render/dynamic-snip val super-render-fun)
(if (behavior? val) (if (behavior? val)
; interesting case: ; interesting case:
; create a snip ; create a snip
@ -139,7 +141,7 @@
; easy case ; easy case
(super-render-fun val))) (super-render-fun val)))
(define (get-rendering val super-render-fun) (define (get-rendering val super-render-fun)
(let-values ([(in out) (make-pipe-with-specials)]) (let-values ([(in out) (make-pipe-with-specials)])
(thread (lambda () (super-render-fun val out) (close-output-port out))) (thread (lambda () (super-render-fun val out) (close-output-port out)))
(let loop ([chars empty]) (let loop ([chars empty])
@ -148,7 +150,7 @@
(reverse (rest chars)) (reverse (rest chars))
(loop (cons c chars))))))) (loop (cons c chars)))))))
(define (watch beh super-render-fun) (define (watch beh super-render-fun)
(cond (cond
[(undefined? beh) [(undefined? beh)
(begin (begin
@ -163,5 +165,4 @@
(make-object dynamic-snip% beh super-render-fun)] (make-object dynamic-snip% beh super-render-fun)]
[else beh])) [else beh]))
(provide (all-defined)) (provide (all-defined-out))
)

18
collects/frtime/frtime-tool.ss
View File

@ -1,16 +1,16 @@
#lang scheme/base
(module frtime-tool mzscheme (require scheme/unit
(require mzlib/unit scheme/class
mzlib/class scheme/bool
mred mred
mzlib/etc (only-in mzlib/etc identity)
mzlib/list scheme/list
drscheme/tool drscheme/tool
string-constants) string-constants)
(provide tool@) (provide tool@)
(define tool@ (define tool@
(unit (unit
(import drscheme:tool^) (import drscheme:tool^)
(export drscheme:tool-exports^) (export drscheme:tool-exports^)
@ -91,4 +91,4 @@
(define (phase1) (void)) (define (phase1) (void))
(define (phase2) (define (phase2)
(drscheme:language-configuration:add-language (drscheme:language-configuration:add-language
(make-object ((drscheme:language:get-default-mixin) (make-frtime-language big-frtime-language%)))))))) (make-object ((drscheme:language:get-default-mixin) (make-frtime-language big-frtime-language%)))))))

16
collects/frtime/graphics-sig.ss
View File

@ -1,12 +1,12 @@
(module graphics-sig mzscheme #lang scheme
(require mzlib/unit) (require scheme/unit)
(provide graphics^ graphics:posn-less^ graphics:posn^) (provide graphics^ graphics:posn-less^ graphics:posn^)
(define-signature graphics:posn^ (define-signature graphics:posn^
(make-posn posn? posn-x posn-y set-posn-x! set-posn-y!)) (make-posn posn? posn-x posn-y set-posn-x! set-posn-y!))
(define-signature graphics:posn-less^ (define-signature graphics:posn-less^
(viewport? (viewport?
sixkey-value sixkey-shift sixkey-control sixkey-meta sixkey-alt sixkey-value sixkey-shift sixkey-control sixkey-meta sixkey-alt
@ -63,10 +63,6 @@
viewport-dc viewport-buffer-dc)) viewport-dc viewport-buffer-dc))
(define-signature graphics^ (define-signature graphics^
((open graphics:posn-less^) ((open graphics:posn-less^)
(open graphics:posn^))) (open graphics:posn^)))
)

15
collects/frtime/graphics-unit.ss
View File

@ -1,15 +1,14 @@
(module graphics-unit mzscheme #lang scheme
(require mzlib/unit (require scheme/unit
mred/mred-sig mred/mred-sig
"graphics-sig.ss" "graphics-sig.ss"
"graphics-posn-less-unit.ss") "graphics-posn-less-unit.ss")
(provide graphics@) (provide graphics@)
(define-unit posn@ (import) (export graphics:posn^) (define-unit posn@ (import) (export graphics:posn^)
(define-struct posn (x y))) (define-struct posn (x y) #:mutable))
(define-compound-unit/infer graphics@ (define-compound-unit/infer graphics@
(import mred^) (import mred^)
(export graphics:posn^ graphics:posn-less^) (export graphics:posn^ graphics:posn-less^)
(link posn@ graphics-posn-less@))) (link posn@ graphics-posn-less@))

8
collects/frtime/graphics.ss
View File

@ -1,9 +1,9 @@
(module graphics mzscheme #lang scheme
(require mzlib/unit (require scheme/unit
mred/mred-sig mred/mred-sig
mred mred
"graphics-sig.ss" "graphics-sig.ss"
"graphics-unit.ss") "graphics-unit.ss")
(provide-signature-elements graphics:posn^ graphics:posn-less^) (provide-signature-elements graphics:posn^ graphics:posn-less^)
(define-values/invoke-unit/infer graphics@)) (define-values/invoke-unit/infer graphics@)

100
collects/frtime/lowered-equivs.ss
View File

@ -1,108 +1,110 @@
;; This module defines all the logic necessary for working with lowered ;; This module defines all the logic necessary for working with lowered
;; equivalents at the syntactic level. That is, it treats functions simply ;; equivalents at the syntactic level. That is, it treats functions simply
;; as syntactic identifiers. ;; as syntactic identifiers.
(module lowered-equivs mzscheme #lang scheme
(provide (all-defined)) (provide (except-out (all-defined-out)
(require mzlib/list) module-identifier=?))
(require (only srfi/1 any)) (require (only-in srfi/1 any))
(define lowered-equiv-suffix ":lowered-equiv") (define module-identifier=? free-identifier=?)
;; Given an identifier for a normal binding, return the identifier (define lowered-equiv-suffix ":lowered-equiv")
;; to be used for the lowered equivalent of that binding.
(define (make-lowered-equiv-id id-stx) ;; Given an identifier for a normal binding, return the identifier
(datum->syntax-object ;; to be used for the lowered equivalent of that binding.
(define (make-lowered-equiv-id id-stx)
(datum->syntax
id-stx id-stx
(string->symbol (string->symbol
(format "~a~a" (syntax-e id-stx) lowered-equiv-suffix)))) (format "~a~a" (syntax-e id-stx) lowered-equiv-suffix))))
;; does the given string end with the given suffix? ;; does the given string end with the given suffix?
(define (string-ends-with str suffix) (define (string-ends-with str suffix)
(string=? (substring str (max 0 (- (string-length str) (string=? (substring str (max 0 (- (string-length str)
(string-length suffix)))) (string-length suffix))))
suffix)) suffix))
;; is the given identifier a lowered equiv identifier? ;; is the given identifier a lowered equiv identifier?
(define (lowered-equiv-id? id-stx) (define (lowered-equiv-id? id-stx)
(and (identifier? id-stx) (and (identifier? id-stx)
(string-ends-with (symbol->string (syntax-e id-stx)) (string-ends-with (symbol->string (syntax-e id-stx))
lowered-equiv-suffix))) lowered-equiv-suffix)))
;; strip the lowered-equiv suffix from an identifier ;; strip the lowered-equiv suffix from an identifier
(define (lowered-equiv-id->lifted-id id-stx) (define (lowered-equiv-id->lifted-id id-stx)
(let ([name (symbol->string (syntax-e id-stx))]) (let ([name (symbol->string (syntax-e id-stx))])
(datum->syntax-object (datum->syntax
id-stx id-stx
(string->symbol (string->symbol
(substring name 0 (- (string-length name) (substring name 0 (- (string-length name)
(string-length lowered-equiv-suffix))))))) (string-length lowered-equiv-suffix)))))))
;; Exception used to indicate that an expression cannot be lowered because ;; Exception used to indicate that an expression cannot be lowered because
;; it has no lowered equivalent. ;; it has no lowered equivalent.
(define-struct exn:no-lowered-equiv (reason)) (define-struct exn:no-lowered-equiv (reason))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Equiv maps translate function names to the name of a lowered equivalent. ;; Equiv maps translate function names to the name of a lowered equivalent.
;; Equiv maps are represented as a list of (func . lowered-equiv) pairs. ;; Equiv maps are represented as a list of (func . lowered-equiv) pairs.
;; empty equiv map ;; empty equiv map
(define (empty-equiv-map) (define (empty-equiv-map)
(list)) (list))
;; add a new func/lowered-equiv mapping to an equiv map (overwrites any ;; add a new func/lowered-equiv mapping to an equiv map (overwrites any
;; existing mapping) ;; existing mapping)
(define (add-equiv-map old-equiv-map new-func new-lowered-func) (define (add-equiv-map old-equiv-map new-func new-lowered-func)
(cons (cons new-func new-lowered-func) (cons (cons new-func new-lowered-func)
old-equiv-map)) old-equiv-map))
;; remove a func/lowered-equiv mapping from an equiv map (no effect if ;; remove a func/lowered-equiv mapping from an equiv map (no effect if
;; the func isn't actually in the mapping) ;; the func isn't actually in the mapping)
(define (del-equiv-map old-equiv-map func-to-remove) (define (del-equiv-map old-equiv-map func-to-remove)
(filter (lambda (pair) (filter (lambda (pair)
(not (module-identifier=? (car pair) func-to-remove))) (not (module-identifier=? (car pair) func-to-remove)))
old-equiv-map)) old-equiv-map))
;; remove a list of funcs from an equiv map ;; remove a list of funcs from an equiv map
(define (del-equiv-map* old-equiv-map ids-to-remove) (define (del-equiv-map* old-equiv-map ids-to-remove)
(foldl del-equiv-map old-equiv-map ids-to-remove)) (foldl del-equiv-map old-equiv-map ids-to-remove))
;; Returns the lowered-equiv for a function, or #f if there is none. ;; Returns the lowered-equiv for a function, or #f if there is none.
(define (lookup-lowered-equiv equiv-map func) (define (lookup-lowered-equiv equiv-map func)
(if (null? equiv-map) (if (null? equiv-map)
#f #f
(if (module-identifier=? (caar equiv-map) func) (if (module-identifier=? (caar equiv-map) func)
(cdar equiv-map) (cdar equiv-map)
(lookup-lowered-equiv (cdr equiv-map) func)))) (lookup-lowered-equiv (cdr equiv-map) func))))
;; Returns the lowered-equiv for a function, or throws exn:no-lowered-equiv. ;; Returns the lowered-equiv for a function, or throws exn:no-lowered-equiv.
(define (get-lowered-equiv equiv-map func) (define (get-lowered-equiv equiv-map func)
(let ([ret (lookup-lowered-equiv equiv-map func)]) (let ([ret (lookup-lowered-equiv equiv-map func)])
(if ret (if ret
ret ret
(raise (make-exn:no-lowered-equiv (raise (make-exn:no-lowered-equiv
(format "no lowered equiv for ~s" (syntax-object->datum func))))))) (format "no lowered equiv for ~s" (syntax->datum func)))))))
;; convert syntax of the form ((func lowered-equiv) ...) to an equiv map ;; convert syntax of the form ((func lowered-equiv) ...) to an equiv map
(define (stx-to-equiv-map stx) (define (stx-to-equiv-map stx)
(syntax-case stx () (syntax-case stx ()
(() (empty-equiv-map)) (() (empty-equiv-map))
(((lifted lowered) rest ...) (((lifted lowered) rest ...)
(add-equiv-map (stx-to-equiv-map #'(rest ...)) #'lifted #'lowered)))) (add-equiv-map (stx-to-equiv-map #'(rest ...)) #'lifted #'lowered))))
;; convert an equiv map to syntax of the form ((func lowered-equiv) ...) ;; convert an equiv map to syntax of the form ((func lowered-equiv) ...)
(define (equiv-map-to-stx equiv-map) (define (equiv-map-to-stx equiv-map)
(datum->syntax-object #'here (datum->syntax #'here
(map (lambda (pair) (list (car pair) (cdr pair))) (map (lambda (pair) (list (car pair) (cdr pair)))
equiv-map))) equiv-map)))
;; combine two equiv maps ;; combine two equiv maps
(define (union-equiv-maps . equiv-maps) (define (union-equiv-maps . equiv-maps)
(apply append equiv-maps)) (apply append equiv-maps))
;; convert a list of symbols to an equiv map, by searching for symbols ;; convert a list of symbols to an equiv map, by searching for symbols
;; that have a matching lowered equivalent symbol. All other symbols ;; that have a matching lowered equivalent symbol. All other symbols
;; are ignored. ;; are ignored.
(define (symbol-list-to-equiv-map symbol-list) (define (symbol-list-to-equiv-map symbol-list)
(foldl (lambda (func equiv-map) (foldl (lambda (func equiv-map)
(if (lowered-equiv-id? func) (if (lowered-equiv-id? func)
(add-equiv-map (add-equiv-map
@ -111,5 +113,3 @@
equiv-map)) equiv-map))
(empty-equiv-map) (empty-equiv-map)
symbol-list)) symbol-list))
)