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

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

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

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

@ -1,16 +1,16 @@
(module frtime-tool mzscheme
(require mzlib/unit
mzlib/class
#lang scheme/base
(require scheme/unit
scheme/class
scheme/bool
mred
mzlib/etc
mzlib/list
(only-in mzlib/etc identity)
scheme/list
drscheme/tool
string-constants)
(provide tool@)
(provide tool@)
(define tool@
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
@ -91,4 +91,4 @@
(define (phase1) (void))
(define (phase2)
(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
(require mzlib/unit)
#lang scheme
(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!))
(define-signature graphics:posn-less^
(define-signature graphics:posn-less^
(viewport?
sixkey-value sixkey-shift sixkey-control sixkey-meta sixkey-alt
@ -63,10 +63,6 @@
viewport-dc viewport-buffer-dc))
(define-signature graphics^
(define-signature graphics^
((open graphics:posn-less^)
(open graphics:posn^)))
)

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

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