Converting to scheme from mzscheme
svn: r15281
This commit is contained in:
Jay McCarthy
parent
5b505d6f5c
commit
a7256c91bf
|
|
@ -1,392 +1,359 @@
|
|||
#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
|
||||
|
||||
date->julian/scalinger
|
||||
julian/scalinger->string))
|
||||
date-display-format
|
||||
find-seconds
|
||||
|
||||
date->julian/scalinger
|
||||
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 legal-formats
|
||||
(list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))
|
||||
|
||||
(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 date-display-format
|
||||
(make-parameter 'american
|
||||
(lambda (s)
|
||||
(unless (memq s legal-formats)
|
||||
(raise-type-error 'date-display-format
|
||||
(format "symbol in ~a" legal-formats)
|
||||
s))
|
||||
s)))
|
||||
|
||||
|#
|
||||
(define month/number->string
|
||||
(lambda (x)
|
||||
(case x
|
||||
[(12) "December"] [(1) "January"] [(2) "February"]
|
||||
[(3) "March"] [(4) "April"] [(5) "May"]
|
||||
[(6) "June"] [(7) "July"] [(8) "August"]
|
||||
[(9) "September"] [(10) "October"] [(11) "November"]
|
||||
[else ""])))
|
||||
|
||||
(define legal-formats
|
||||
(list 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))
|
||||
(define day/number->string
|
||||
(lambda (x)
|
||||
(case x
|
||||
[(0) "Sunday"]
|
||||
[(1) "Monday"]
|
||||
[(2) "Tuesday"]
|
||||
[(3) "Wednesday"]
|
||||
[(4) "Thursday"]
|
||||
[(5) "Friday"]
|
||||
[(6) "Saturday"]
|
||||
[else ""])))
|
||||
|
||||
(define date-display-format
|
||||
(make-parameter 'american
|
||||
(lambda (s)
|
||||
(unless (memq s legal-formats)
|
||||
(raise-type-error 'date-display-format
|
||||
(format "symbol in ~a" legal-formats)
|
||||
s))
|
||||
s)))
|
||||
(define date->string
|
||||
(case-lambda
|
||||
[(date) (date->string date #f)]
|
||||
[(date time?)
|
||||
(let* ((add-zero (lambda (n) (if (< n 10)
|
||||
(string-append "0" (number->string n))
|
||||
(number->string n))))
|
||||
(year (number->string (date-year date)))
|
||||
(num-month (number->string (date-month date)))
|
||||
(week-day (day/number->string (date-week-day date)))
|
||||
(week-day-num (date-week-day date))
|
||||
(month (month/number->string (date-month date)))
|
||||
(day (number->string (date-day date)))
|
||||
(day-th (if (<= 11 (date-day date) 13)
|
||||
"th"
|
||||
(case (modulo (date-day date) 10)
|
||||
[(1) "st"]
|
||||
[(2) "nd"]
|
||||
[(3) "rd"]
|
||||
[(0 4 5 6 7 8 9) "th"])))
|
||||
(hour (date-hour date))
|
||||
(am-pm (if (>= hour 12) "pm" "am"))
|
||||
(hour24 (add-zero hour))
|
||||
(hour12 (number->string
|
||||
(cond
|
||||
[(zero? hour) 12]
|
||||
[(> hour 12) (- hour 12)]
|
||||
[else hour])))
|
||||
(minute (add-zero (date-minute date)))
|
||||
(second (add-zero (date-second date))))
|
||||
(let-values
|
||||
([(day time)
|
||||
(case (date-display-format)
|
||||
[(american)
|
||||
(values (list week-day ", " month " " day day-th ", " year)
|
||||
(list " " hour12 ":" minute ":" second am-pm))]
|
||||
[(chinese)
|
||||
(values
|
||||
(list year "/" num-month "/" day
|
||||
" \u661F\u671F" (case (date-week-day date)
|
||||
[(0) "\u5929"]
|
||||
[(1) "\u4E00"]
|
||||
[(2) "\u4E8C"]
|
||||
[(3) "\u4e09"]
|
||||
[(4) "\u56DB"]
|
||||
[(5) "\u4E94"]
|
||||
[(6) "\u516D"]
|
||||
[else ""]))
|
||||
(list " " hour24 ":" minute ":" second))]
|
||||
[(indian)
|
||||
(values (list day "-" num-month "-" year)
|
||||
(list " " hour12 ":" minute ":" second am-pm))]
|
||||
[(german)
|
||||
(values (list day ". "
|
||||
(case (date-month date)
|
||||
[(1) "Januar"]
|
||||
[(2) "Februar"]
|
||||
[(3) "M\344rz"]
|
||||
[(4) "April"]
|
||||
[(5) "Mai"]
|
||||
[(6) "Juni"]
|
||||
[(7) "Juli"]
|
||||
[(8) "August"]
|
||||
[(9) "September"]
|
||||
[(10) "Oktober"]
|
||||
[(11) "November"]
|
||||
[(12) "Dezember"]
|
||||
[else ""])
|
||||
" " year)
|
||||
(list ", " hour24 "." minute))]
|
||||
[(irish)
|
||||
(values (list week-day ", " day day-th " " month " " year)
|
||||
(list ", " hour12 ":" minute am-pm))]
|
||||
[(julian)
|
||||
(values (list (julian/scalinger->string
|
||||
(date->julian/scalinger date)))
|
||||
(list ", " hour24 ":" minute ":" second))]
|
||||
[(iso-8601)
|
||||
(values
|
||||
(list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date)))
|
||||
(list " " hour24 ":" minute ":" second))]
|
||||
[(rfc2822)
|
||||
(values
|
||||
(list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year)
|
||||
(list* " " hour24 ":" minute ":" second " "
|
||||
(let* ([delta (date-time-zone-offset date)]
|
||||
[hours (quotient delta 3600)]
|
||||
[minutes (modulo (quotient delta 60) 60)])
|
||||
(list
|
||||
(if (negative? delta) "-" "")
|
||||
(add-zero (abs hours))
|
||||
(add-zero minutes)))))]
|
||||
[else (error 'date->string "unknown date-display-format: ~s"
|
||||
(date-display-format))])])
|
||||
(apply string-append (if time?
|
||||
(append day time)
|
||||
day))))]))
|
||||
|
||||
(define month/number->string
|
||||
(lambda (x)
|
||||
(case x
|
||||
[(12) "December"] [(1) "January"] [(2) "February"]
|
||||
[(3) "March"] [(4) "April"] [(5) "May"]
|
||||
[(6) "June"] [(7) "July"] [(8) "August"]
|
||||
[(9) "September"] [(10) "October"] [(11) "November"]
|
||||
[else ""])))
|
||||
|
||||
(define day/number->string
|
||||
(lambda (x)
|
||||
(case x
|
||||
[(0) "Sunday"]
|
||||
[(1) "Monday"]
|
||||
[(2) "Tuesday"]
|
||||
[(3) "Wednesday"]
|
||||
[(4) "Thursday"]
|
||||
[(5) "Friday"]
|
||||
[(6) "Saturday"]
|
||||
[else ""])))
|
||||
(define leap-year?
|
||||
(lambda (year)
|
||||
(or (= 0 (modulo year 400))
|
||||
(and (= 0 (modulo year 4))
|
||||
(not (= 0 (modulo year 100)))))))
|
||||
|
||||
(define date->string
|
||||
;; it's not clear what months mean in this context -- use days
|
||||
(define-struct date-offset (second minute hour day year))
|
||||
|
||||
(define date-
|
||||
(lambda (date1 date2)
|
||||
(let* ((second (- (date-second date1) (date-second date2)))
|
||||
(minute (+ (- (date-minute date1) (date-minute date2))
|
||||
(if (< second 0) -1 0)))
|
||||
(hour (+ (- (date-hour date1) (date-hour date2))
|
||||
(if (< minute 0) -1 0)
|
||||
(cond [(equal? (date-dst? date1) (date-dst? date2)) 0]
|
||||
[(date-dst? date1) -1]
|
||||
[(date-dst? date2) 1])))
|
||||
(day (+ (- (date-year-day date1) (date-year-day date2))
|
||||
(if (< hour 0) -1 0)))
|
||||
(year (+ (- (date-year date1) (date-year date2))
|
||||
(if (< day 0) -1 0)))
|
||||
(fixup (lambda (s x) (if (< s 0) (+ s x) s))))
|
||||
(make-date-offset (fixup second 60)
|
||||
(fixup minute 60)
|
||||
(fixup hour 24)
|
||||
(fixup day (if (leap-year? (date-year date1)) 366 365))
|
||||
year))))
|
||||
|
||||
|
||||
(define date-offset->string
|
||||
(let ((first car)
|
||||
(second cadr))
|
||||
(case-lambda
|
||||
[(date) (date->string date #f)]
|
||||
[(date time?)
|
||||
(let* ((add-zero (lambda (n) (if (< n 10)
|
||||
(string-append "0" (number->string n))
|
||||
(number->string n))))
|
||||
(year (number->string (date-year date)))
|
||||
(num-month (number->string (date-month date)))
|
||||
(week-day (day/number->string (date-week-day date)))
|
||||
(week-day-num (date-week-day date))
|
||||
(month (month/number->string (date-month date)))
|
||||
(day (number->string (date-day date)))
|
||||
(day-th (if (<= 11 (date-day date) 13)
|
||||
"th"
|
||||
(case (modulo (date-day date) 10)
|
||||
[(1) "st"]
|
||||
[(2) "nd"]
|
||||
[(3) "rd"]
|
||||
[(0 4 5 6 7 8 9) "th"])))
|
||||
(hour (date-hour date))
|
||||
(am-pm (if (>= hour 12) "pm" "am"))
|
||||
(hour24 (add-zero hour))
|
||||
(hour12 (number->string
|
||||
(cond
|
||||
[(zero? hour) 12]
|
||||
[(> hour 12) (- hour 12)]
|
||||
[else hour])))
|
||||
(minute (add-zero (date-minute date)))
|
||||
(second (add-zero (date-second date))))
|
||||
(let-values
|
||||
([(day time)
|
||||
(case (date-display-format)
|
||||
[(american)
|
||||
(values (list week-day ", " month " " day day-th ", " year)
|
||||
(list " " hour12 ":" minute ":" second am-pm))]
|
||||
[(chinese)
|
||||
(values
|
||||
(list year "/" num-month "/" day
|
||||
" \u661F\u671F" (case (date-week-day date)
|
||||
[(0) "\u5929"]
|
||||
[(1) "\u4E00"]
|
||||
[(2) "\u4E8C"]
|
||||
[(3) "\u4e09"]
|
||||
[(4) "\u56DB"]
|
||||
[(5) "\u4E94"]
|
||||
[(6) "\u516D"]
|
||||
[else ""]))
|
||||
(list " " hour24 ":" minute ":" second))]
|
||||
[(indian)
|
||||
(values (list day "-" num-month "-" year)
|
||||
(list " " hour12 ":" minute ":" second am-pm))]
|
||||
[(german)
|
||||
(values (list day ". "
|
||||
(case (date-month date)
|
||||
[(1) "Januar"]
|
||||
[(2) "Februar"]
|
||||
[(3) "M\344rz"]
|
||||
[(4) "April"]
|
||||
[(5) "Mai"]
|
||||
[(6) "Juni"]
|
||||
[(7) "Juli"]
|
||||
[(8) "August"]
|
||||
[(9) "September"]
|
||||
[(10) "Oktober"]
|
||||
[(11) "November"]
|
||||
[(12) "Dezember"]
|
||||
[else ""])
|
||||
" " year)
|
||||
(list ", " hour24 "." minute))]
|
||||
[(irish)
|
||||
(values (list week-day ", " day day-th " " month " " year)
|
||||
(list ", " hour12 ":" minute am-pm))]
|
||||
[(julian)
|
||||
(values (list (julian/scalinger->string
|
||||
(date->julian/scalinger date)))
|
||||
(list ", " hour24 ":" minute ":" second))]
|
||||
[(iso-8601)
|
||||
(values
|
||||
(list year "-" (add-zero (date-month date)) "-" (add-zero (date-day date)))
|
||||
(list " " hour24 ":" minute ":" second))]
|
||||
[(rfc2822)
|
||||
(values
|
||||
(list (substring week-day 0 3) ", " day " " (substring month 0 3) " " year)
|
||||
(list* " " hour24 ":" minute ":" second " "
|
||||
(let* ([delta (date-time-zone-offset date)]
|
||||
[hours (quotient delta 3600)]
|
||||
[minutes (modulo (quotient delta 60) 60)])
|
||||
(list
|
||||
(if (negative? delta) "-" "")
|
||||
(add-zero (abs hours))
|
||||
(add-zero minutes)))))]
|
||||
[else (error 'date->string "unknown date-display-format: ~s"
|
||||
(date-display-format))])])
|
||||
(apply string-append (if time?
|
||||
(append day time)
|
||||
day))))]))
|
||||
|
||||
(define leap-year?
|
||||
(lambda (year)
|
||||
(or (= 0 (modulo year 400))
|
||||
(and (= 0 (modulo year 4))
|
||||
(not (= 0 (modulo year 100)))))))
|
||||
[(date) (date-offset->string date #f)]
|
||||
[(date seconds?)
|
||||
(let* ((fields (list (list (date-offset-year date) "year")
|
||||
(list (date-offset-day date) "day")
|
||||
(list (date-offset-hour date) "hour")
|
||||
(list (date-offset-minute date) "minute")
|
||||
(list (if seconds? (date-offset-second date) 0) "second")))
|
||||
(non-zero-fields (foldl (lambda (x l)
|
||||
(if (= 0 (first x))
|
||||
l
|
||||
(cons x l)))
|
||||
null
|
||||
fields))
|
||||
(one-entry (lambda (b)
|
||||
(string-append
|
||||
(number->string (first b))
|
||||
" "
|
||||
(second b)
|
||||
(if (= 1 (first b)) "" "s")))))
|
||||
(cond
|
||||
[(null? non-zero-fields) ""]
|
||||
[(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))]
|
||||
[else (foldl (lambda (b string)
|
||||
(cond
|
||||
[(= 0 (first b)) string]
|
||||
[(string=? string "")
|
||||
(string-append "and "
|
||||
(one-entry b)
|
||||
string)]
|
||||
[else (string-append (one-entry b) ", " string)]))
|
||||
""
|
||||
non-zero-fields)]))])))
|
||||
|
||||
;; it's not clear what months mean in this context -- use days
|
||||
(define-struct date-offset (second minute hour day year))
|
||||
(define days-per-month
|
||||
(lambda (year month)
|
||||
(cond
|
||||
[(and (= month 2) (leap-year? year)) 29]
|
||||
[(= month 2) 28]
|
||||
[(<= month 7) (+ 30 (modulo month 2))]
|
||||
[else (+ 30 (- 1 (modulo month 2)))])))
|
||||
|
||||
(define date-
|
||||
(lambda (date1 date2)
|
||||
(let* ((second (- (date-second date1) (date-second date2)))
|
||||
(minute (+ (- (date-minute date1) (date-minute date2))
|
||||
(if (< second 0) -1 0)))
|
||||
(hour (+ (- (date-hour date1) (date-hour date2))
|
||||
(if (< minute 0) -1 0)
|
||||
(cond [(equal? (date-dst? date1) (date-dst? date2)) 0]
|
||||
[(date-dst? date1) -1]
|
||||
[(date-dst? date2) 1])))
|
||||
(day (+ (- (date-year-day date1) (date-year-day date2))
|
||||
(if (< hour 0) -1 0)))
|
||||
(year (+ (- (date-year date1) (date-year date2))
|
||||
(if (< day 0) -1 0)))
|
||||
(fixup (lambda (s x) (if (< s 0) (+ s x) s))))
|
||||
(make-date-offset (fixup second 60)
|
||||
(fixup minute 60)
|
||||
(fixup hour 24)
|
||||
(fixup day (if (leap-year? (date-year date1)) 366 365))
|
||||
year))))
|
||||
(define find-extreme-date-seconds
|
||||
(lambda (start offset)
|
||||
(let/ec found
|
||||
(letrec ([find-between
|
||||
(lambda (lo hi)
|
||||
(let ([mid (floor (/ (+ lo hi) 2))])
|
||||
(if (or (and (positive? offset) (= lo mid))
|
||||
(and (negative? offset) (= hi mid)))
|
||||
(found lo)
|
||||
(let ([mid-ok?
|
||||
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
||||
(seconds->date mid)
|
||||
#t)])
|
||||
(if mid-ok?
|
||||
(find-between mid hi)
|
||||
(find-between lo mid))))))])
|
||||
(let loop ([lo start][offset offset])
|
||||
(let ([hi (+ lo offset)])
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
; failed - must be between lo & hi
|
||||
(find-between lo hi))])
|
||||
(seconds->date hi))
|
||||
; succeeded; double offset again
|
||||
(loop hi (* 2 offset))))))))
|
||||
|
||||
(define get-min-seconds
|
||||
(let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
|
||||
(lambda ()
|
||||
(force d))))
|
||||
(define get-max-seconds
|
||||
(let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
|
||||
(lambda ()
|
||||
(force d))))
|
||||
|
||||
(define date-offset->string
|
||||
(let ((first car)
|
||||
(second cadr))
|
||||
(case-lambda
|
||||
[(date) (date-offset->string date #f)]
|
||||
[(date seconds?)
|
||||
(let* ((fields (list (list (date-offset-year date) "year")
|
||||
(list (date-offset-day date) "day")
|
||||
(list (date-offset-hour date) "hour")
|
||||
(list (date-offset-minute date) "minute")
|
||||
(list (if seconds? (date-offset-second date) 0) "second")))
|
||||
(non-zero-fields (foldl (lambda (x l)
|
||||
(if (= 0 (first x))
|
||||
l
|
||||
(cons x l)))
|
||||
null
|
||||
fields))
|
||||
(one-entry (lambda (b)
|
||||
(string-append
|
||||
(number->string (first b))
|
||||
" "
|
||||
(second b)
|
||||
(if (= 1 (first b)) "" "s")))))
|
||||
(cond
|
||||
[(null? non-zero-fields) ""]
|
||||
[(null? (cdr non-zero-fields)) (one-entry (car non-zero-fields))]
|
||||
[else (foldl (lambda (b string)
|
||||
(cond
|
||||
[(= 0 (first b)) string]
|
||||
[(string=? string "")
|
||||
(string-append "and "
|
||||
(one-entry b)
|
||||
string)]
|
||||
[else (string-append (one-entry b) ", " string)]))
|
||||
""
|
||||
non-zero-fields)]))])))
|
||||
(define find-seconds
|
||||
(lambda (sec min hour day month year)
|
||||
(let ([signal-error
|
||||
(lambda (msg)
|
||||
(error 'find-secs (string-append
|
||||
msg
|
||||
" (inputs: ~a ~a ~a ~a ~a ~a)")
|
||||
sec min hour day month year))])
|
||||
(let loop ([below-secs (get-min-seconds)]
|
||||
[secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
|
||||
[above-secs (get-max-seconds)])
|
||||
(let* ([date (seconds->date secs)]
|
||||
[compare
|
||||
(let loop ([inputs (list year month day
|
||||
hour min sec)]
|
||||
[tests (list (date-year date)
|
||||
(date-month date)
|
||||
(date-day date)
|
||||
(date-hour date)
|
||||
(date-minute date)
|
||||
(date-second date))])
|
||||
(cond
|
||||
[(null? inputs) 'equal]
|
||||
[else (let ([input (car inputs)]
|
||||
[test (car tests)])
|
||||
(if (= input test)
|
||||
(loop (cdr inputs) (cdr tests))
|
||||
(if (<= input test)
|
||||
'input-smaller
|
||||
'test-smaller)))]))])
|
||||
; (printf "~a ~a ~a~n" compare secs (date->string date))
|
||||
(cond
|
||||
[(eq? compare 'equal) secs]
|
||||
[(or (= secs below-secs) (= secs above-secs))
|
||||
(signal-error "non-existent date")]
|
||||
[(eq? compare 'input-smaller)
|
||||
(loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
|
||||
[(eq? compare 'test-smaller)
|
||||
(loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
|
||||
|
||||
(define days-per-month
|
||||
(lambda (year month)
|
||||
(cond
|
||||
[(and (= month 2) (leap-year? year)) 29]
|
||||
[(= month 2) 28]
|
||||
[(<= month 7) (+ 30 (modulo month 2))]
|
||||
[else (+ 30 (- 1 (modulo month 2)))])))
|
||||
;; date->julian/scalinger :
|
||||
;; date -> number [julian-day]
|
||||
|
||||
(define find-extreme-date-seconds
|
||||
(lambda (start offset)
|
||||
(let/ec found
|
||||
(letrec ([find-between
|
||||
(lambda (lo hi)
|
||||
(let ([mid (floor (/ (+ lo hi) 2))])
|
||||
(if (or (and (positive? offset) (= lo mid))
|
||||
(and (negative? offset) (= hi mid)))
|
||||
(found lo)
|
||||
(let ([mid-ok?
|
||||
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
||||
(seconds->date mid)
|
||||
#t)])
|
||||
(if mid-ok?
|
||||
(find-between mid hi)
|
||||
(find-between lo mid))))))])
|
||||
(let loop ([lo start][offset offset])
|
||||
(let ([hi (+ lo offset)])
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
; failed - must be between lo & hi
|
||||
(find-between lo hi))])
|
||||
(seconds->date hi))
|
||||
; succeeded; double offset again
|
||||
(loop hi (* 2 offset))))))))
|
||||
;; Note: This code is correct until 2099 CE Gregorian
|
||||
|
||||
(define get-min-seconds
|
||||
(let ([d (delay (find-extreme-date-seconds (current-seconds) -1))])
|
||||
(lambda ()
|
||||
(force d))))
|
||||
(define get-max-seconds
|
||||
(let ([d (delay (find-extreme-date-seconds (current-seconds) 1))])
|
||||
(lambda ()
|
||||
(force d))))
|
||||
(define (date->julian/scalinger date)
|
||||
(let ((day (date-day date))
|
||||
(month (date-month date))
|
||||
(year (date-year date)))
|
||||
(let ((year (+ 4712 year)))
|
||||
(let ((year (if (< month 3) (sub1 year) year)))
|
||||
(let ((cycle-number (quotient year 4))
|
||||
(cycle-position (remainder year 4)))
|
||||
(let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position))))
|
||||
(let ((month-day-number (case month
|
||||
((3) 0)
|
||||
((4) 31)
|
||||
((5) 61)
|
||||
((6) 92)
|
||||
((7) 122)
|
||||
((8) 153)
|
||||
((9) 184)
|
||||
((10) 214)
|
||||
((11) 245)
|
||||
((12) 275)
|
||||
((1) 306)
|
||||
((2) 337))))
|
||||
(let ((total-days (+ base-day month-day-number day)))
|
||||
(let ((total-days/march-adjustment (+ total-days 59)))
|
||||
(let ((gregorian-adjustment (cond
|
||||
((< year 1700) 11)
|
||||
((< year 1800) 12)
|
||||
(else 13))))
|
||||
(let ((final-date (- total-days/march-adjustment
|
||||
gregorian-adjustment)))
|
||||
final-date)))))))))))
|
||||
|
||||
(define find-seconds
|
||||
(lambda (sec min hour day month year)
|
||||
(let ([signal-error
|
||||
(lambda (msg)
|
||||
(error 'find-secs (string-append
|
||||
msg
|
||||
" (inputs: ~a ~a ~a ~a ~a ~a)")
|
||||
sec min hour day month year))])
|
||||
(let loop ([below-secs (get-min-seconds)]
|
||||
[secs (floor (/ (+ (get-min-seconds) (get-max-seconds)) 2))]
|
||||
[above-secs (get-max-seconds)])
|
||||
(let* ([date (seconds->date secs)]
|
||||
[compare
|
||||
(let loop ([inputs (list year month day
|
||||
hour min sec)]
|
||||
[tests (list (date-year date)
|
||||
(date-month date)
|
||||
(date-day date)
|
||||
(date-hour date)
|
||||
(date-minute date)
|
||||
(date-second date))])
|
||||
(cond
|
||||
[(null? inputs) 'equal]
|
||||
[else (let ([input (car inputs)]
|
||||
[test (car tests)])
|
||||
(if (= input test)
|
||||
(loop (cdr inputs) (cdr tests))
|
||||
(if (<= input test)
|
||||
'input-smaller
|
||||
'test-smaller)))]))])
|
||||
; (printf "~a ~a ~a~n" compare secs (date->string date))
|
||||
(cond
|
||||
[(eq? compare 'equal) secs]
|
||||
[(or (= secs below-secs) (= secs above-secs))
|
||||
(signal-error "non-existent date")]
|
||||
[(eq? compare 'input-smaller)
|
||||
(loop below-secs (floor (/ (+ secs below-secs) 2)) secs)]
|
||||
[(eq? compare 'test-smaller)
|
||||
(loop secs (floor (/ (+ above-secs secs) 2)) above-secs)]))))))
|
||||
|
||||
;; date->julian/scalinger :
|
||||
;; date -> number [julian-day]
|
||||
|
||||
;; Note: This code is correct until 2099 CE Gregorian
|
||||
|
||||
(define (date->julian/scalinger date)
|
||||
(let ((day (date-day date))
|
||||
(month (date-month date))
|
||||
(year (date-year date)))
|
||||
(let ((year (+ 4712 year)))
|
||||
(let ((year (if (< month 3) (sub1 year) year)))
|
||||
(let ((cycle-number (quotient year 4))
|
||||
(cycle-position (remainder year 4)))
|
||||
(let ((base-day (+ (* 1461 cycle-number) (* 365 cycle-position))))
|
||||
(let ((month-day-number (case month
|
||||
((3) 0)
|
||||
((4) 31)
|
||||
((5) 61)
|
||||
((6) 92)
|
||||
((7) 122)
|
||||
((8) 153)
|
||||
((9) 184)
|
||||
((10) 214)
|
||||
((11) 245)
|
||||
((12) 275)
|
||||
((1) 306)
|
||||
((2) 337))))
|
||||
(let ((total-days (+ base-day month-day-number day)))
|
||||
(let ((total-days/march-adjustment (+ total-days 59)))
|
||||
(let ((gregorian-adjustment (cond
|
||||
((< year 1700) 11)
|
||||
((< year 1800) 12)
|
||||
(else 13))))
|
||||
(let ((final-date (- total-days/march-adjustment
|
||||
gregorian-adjustment)))
|
||||
final-date)))))))))))
|
||||
|
||||
;; julian/scalinger->string :
|
||||
;; number [julian-day] -> string [julian-day-format]
|
||||
|
||||
(define (julian/scalinger->string julian-day)
|
||||
(apply string-append
|
||||
(cons "JD "
|
||||
(reverse
|
||||
(let loop ((reversed-digits (map number->string
|
||||
(let loop ((jd julian-day))
|
||||
(if (zero? jd) null
|
||||
(cons (remainder jd 10)
|
||||
(loop (quotient jd 10))))))))
|
||||
(cond
|
||||
((or (null? reversed-digits)
|
||||
(null? (cdr reversed-digits))
|
||||
(null? (cdr (cdr reversed-digits))))
|
||||
(list (apply string-append reversed-digits)))
|
||||
(else (cons (apply string-append
|
||||
(list " "
|
||||
(caddr reversed-digits)
|
||||
(cadr reversed-digits)
|
||||
(car reversed-digits)))
|
||||
(loop (cdr (cdr (cdr reversed-digits))))))))))))
|
||||
|
||||
)
|
||||
;; julian/scalinger->string :
|
||||
;; number [julian-day] -> string [julian-day-format]
|
||||
|
||||
(define (julian/scalinger->string julian-day)
|
||||
(apply string-append
|
||||
(cons "JD "
|
||||
(reverse
|
||||
(let loop ((reversed-digits (map number->string
|
||||
(let loop ((jd julian-day))
|
||||
(if (zero? jd) null
|
||||
(cons (remainder jd 10)
|
||||
(loop (quotient jd 10))))))))
|
||||
(cond
|
||||
((or (null? reversed-digits)
|
||||
(null? (cdr reversed-digits))
|
||||
(null? (cdr (cdr reversed-digits))))
|
||||
(list (apply string-append reversed-digits)))
|
||||
(else (cons (apply string-append
|
||||
(list " "
|
||||
(caddr reversed-digits)
|
||||
(cadr reversed-digits)
|
||||
(car reversed-digits)))
|
||||
(loop (cdr (cdr (cdr reversed-digits))))))))))))
|
||||
|
|
@ -1,167 +1,168 @@
|
|||
(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
|
||||
(except-in frtime/lang-ext
|
||||
undefined?)
|
||||
(only-in frtime/lang-core
|
||||
any-nested-reactivity? raise-reactivity)
|
||||
|
||||
;; MrEd require
|
||||
(except-in mred send-event))
|
||||
|
||||
framework
|
||||
|
||||
;; FRP requires
|
||||
|
||||
frtime/core/frp
|
||||
(all-except frtime/lang-ext undefined?)
|
||||
(only frtime/lang-core any-nested-reactivity? raise-reactivity)
|
||||
(define drs-eventspace #f)
|
||||
|
||||
;; MrEd require
|
||||
(all-except mred send-event))
|
||||
|
||||
(define drs-eventspace #f)
|
||||
|
||||
(define (set-eventspace evspc)
|
||||
(set! drs-eventspace evspc))
|
||||
|
||||
(define value-snip-copy%
|
||||
(class string-snip%
|
||||
(init-field current parent)
|
||||
(inherit get-admin)
|
||||
(define/public (set-current c)
|
||||
(parameterize ([current-eventspace drs-eventspace])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(set! current c)
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(send admin needs-update this 0 0 2000 100)))))))
|
||||
(define/override (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 (" "))))
|
||||
|
||||
(define make-snip
|
||||
(case-lambda
|
||||
[(bhvr)
|
||||
(make-object string-snip%
|
||||
(let ([tmp (cond
|
||||
[(behavior? bhvr) (value-now bhvr)]
|
||||
[(event? bhvr) (signal-value bhvr)]
|
||||
[else bhvr])])
|
||||
(cond
|
||||
[(event-set? tmp) (format "#<event (last: ~a@~a)>"
|
||||
(event-set-events tmp) (event-set-time tmp))]
|
||||
[(undefined? tmp) "<undefined>"]
|
||||
[else (expr->string tmp)])))]
|
||||
[(bhvr super-render-fun)
|
||||
(get-rendering (value-now bhvr) super-render-fun)]))
|
||||
|
||||
(define value-snip%
|
||||
(class string-snip%
|
||||
(init-field bhvr)
|
||||
(field [copies empty]
|
||||
[loc-bhvr (proc->signal (lambda () (update)) bhvr)]
|
||||
[current (make-snip bhvr)])
|
||||
|
||||
(define/override (copy)
|
||||
(let ([ret (make-object value-snip-copy% current this)])
|
||||
(set! copies (cons ret copies))
|
||||
ret))
|
||||
|
||||
(define/public (update)
|
||||
(set! current (make-snip bhvr))
|
||||
(for-each (lambda (copy) (send copy set-current current)) copies))
|
||||
|
||||
(super-instantiate (" "))))
|
||||
|
||||
(define dynamic-snip-copy%
|
||||
(class editor-snip%
|
||||
(init-field current parent)
|
||||
(inherit get-editor)
|
||||
(define/public (set-current c)
|
||||
(parameterize ([current-eventspace drs-eventspace])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(send (get-editor) lock #f)
|
||||
(send (get-editor) delete 0 (send (get-editor) last-position))
|
||||
(for-each (lambda (thing)
|
||||
(send (get-editor) insert thing
|
||||
(send (get-editor) last-position) (send (get-editor) last-position)))
|
||||
c)
|
||||
(send (get-editor) lock #t)))))
|
||||
(define (set-eventspace evspc)
|
||||
(set! drs-eventspace evspc))
|
||||
|
||||
(super-new
|
||||
[editor (new scheme:text%)]
|
||||
[with-border? #f]
|
||||
[left-margin 0]
|
||||
[right-margin 0]
|
||||
[top-margin 0]
|
||||
[bottom-margin 0])
|
||||
(set-current current)))
|
||||
(define value-snip-copy%
|
||||
(class string-snip%
|
||||
(init-field current parent)
|
||||
(inherit get-admin)
|
||||
(define/public (set-current c)
|
||||
(parameterize ([current-eventspace drs-eventspace])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(set! current c)
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(send admin needs-update this 0 0 2000 100)))))))
|
||||
(define/override (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 (" "))))
|
||||
|
||||
(define make-snip
|
||||
(case-lambda
|
||||
[(bhvr)
|
||||
(make-object string-snip%
|
||||
(let ([tmp (cond
|
||||
[(behavior? bhvr) (value-now bhvr)]
|
||||
[(event? bhvr) (signal-value bhvr)]
|
||||
[else bhvr])])
|
||||
(cond
|
||||
[(event-set? tmp) (format "#<event (last: ~a@~a)>"
|
||||
(event-set-events tmp) (event-set-time tmp))]
|
||||
[(undefined? tmp) "<undefined>"]
|
||||
[else (expr->string tmp)])))]
|
||||
[(bhvr super-render-fun)
|
||||
(get-rendering (value-now bhvr) super-render-fun)]))
|
||||
|
||||
(define value-snip%
|
||||
(class string-snip%
|
||||
(init-field bhvr)
|
||||
(field [copies empty]
|
||||
[loc-bhvr (proc->signal (lambda () (update)) bhvr)]
|
||||
[current (make-snip bhvr)])
|
||||
|
||||
(define dynamic-snip%
|
||||
(class snip%
|
||||
(init-field bhvr super-render-fun)
|
||||
|
||||
(field [copies empty]
|
||||
[loc-bhvr (proc->signal (lambda () (update)) bhvr)]
|
||||
[current (make-snip bhvr super-render-fun)])
|
||||
|
||||
(define/override (copy)
|
||||
(let ([ret (make-object dynamic-snip-copy% current this)])
|
||||
(set! copies (cons ret copies))
|
||||
ret))
|
||||
|
||||
(define/public (update)
|
||||
(set! current (make-snip bhvr super-render-fun))
|
||||
(for-each (lambda (copy) (send copy set-current current)) copies))
|
||||
|
||||
(define/override (size-cache-invalid)
|
||||
(for-each
|
||||
(lambda (s) (send s size-cache-invalid))
|
||||
copies))
|
||||
|
||||
(define/override (get-extent dc x y w h descent space lspace rspace)
|
||||
(send current get-extent dc x y w h descent space lspace rspace))
|
||||
(define/override (copy)
|
||||
(let ([ret (make-object value-snip-copy% current this)])
|
||||
(set! copies (cons ret copies))
|
||||
ret))
|
||||
|
||||
(define/public (update)
|
||||
(set! current (make-snip bhvr))
|
||||
(for-each (lambda (copy) (send copy set-current current)) copies))
|
||||
|
||||
(super-instantiate (" "))))
|
||||
|
||||
(super-new)))
|
||||
(define dynamic-snip-copy%
|
||||
(class editor-snip%
|
||||
(init-field current parent)
|
||||
(inherit get-editor)
|
||||
(define/public (set-current c)
|
||||
(parameterize ([current-eventspace drs-eventspace])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(send (get-editor) lock #f)
|
||||
(send (get-editor) delete 0 (send (get-editor) last-position))
|
||||
(for-each (lambda (thing)
|
||||
(send (get-editor) insert thing
|
||||
(send (get-editor) last-position) (send (get-editor) last-position)))
|
||||
c)
|
||||
(send (get-editor) lock #t)))))
|
||||
|
||||
(super-new
|
||||
[editor (new scheme:text%)]
|
||||
[with-border? #f]
|
||||
[left-margin 0]
|
||||
[right-margin 0]
|
||||
[top-margin 0]
|
||||
[bottom-margin 0])
|
||||
(set-current current)))
|
||||
|
||||
(define (render beh as-snip?)
|
||||
(cond
|
||||
[as-snip? (watch beh)]
|
||||
[(undefined? (value-now beh)) "<undefined>"]
|
||||
[(behavior? beh) (format "#<behavior (~a)>" (value-now beh))]
|
||||
[(event? beh) (format "#<event (last: ~a)>" (event-set-events (signal-value beh)))]
|
||||
[else beh]))
|
||||
|
||||
(define (render/dynamic-snip val super-render-fun)
|
||||
(if (behavior? val)
|
||||
; interesting case:
|
||||
; create a snip
|
||||
; each time val changes, recompute its rendering via super-render-fun
|
||||
(make-object dynamic-snip% val super-render-fun)
|
||||
; easy case
|
||||
(super-render-fun val)))
|
||||
|
||||
(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])
|
||||
(let ([c (read-char-or-special in)])
|
||||
(if (eof-object? c)
|
||||
(reverse (rest chars))
|
||||
(loop (cons c chars)))))))
|
||||
|
||||
(define (watch beh super-render-fun)
|
||||
(cond
|
||||
[(undefined? beh)
|
||||
(begin
|
||||
(make-object string-snip% "<undefined>")
|
||||
)
|
||||
]
|
||||
[(event? beh)
|
||||
(make-object value-snip% beh)]
|
||||
[(or (behavior? beh) (any-nested-reactivity? beh))
|
||||
(make-object dynamic-snip% (raise-reactivity beh) super-render-fun)]
|
||||
[(signal? beh)
|
||||
(make-object dynamic-snip% beh super-render-fun)]
|
||||
[else beh]))
|
||||
|
||||
(provide (all-defined))
|
||||
)
|
||||
(define dynamic-snip%
|
||||
(class snip%
|
||||
(init-field bhvr super-render-fun)
|
||||
|
||||
(field [copies empty]
|
||||
[loc-bhvr (proc->signal (lambda () (update)) bhvr)]
|
||||
[current (make-snip bhvr super-render-fun)])
|
||||
|
||||
(define/override (copy)
|
||||
(let ([ret (make-object dynamic-snip-copy% current this)])
|
||||
(set! copies (cons ret copies))
|
||||
ret))
|
||||
|
||||
(define/public (update)
|
||||
(set! current (make-snip bhvr super-render-fun))
|
||||
(for-each (lambda (copy) (send copy set-current current)) copies))
|
||||
|
||||
(define/override (size-cache-invalid)
|
||||
(for-each
|
||||
(lambda (s) (send s size-cache-invalid))
|
||||
copies))
|
||||
|
||||
(define/override (get-extent dc x y w h descent space lspace rspace)
|
||||
(send current get-extent dc x y w h descent space lspace rspace))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define (render beh as-snip?)
|
||||
(cond
|
||||
[as-snip? (watch beh)]
|
||||
[(undefined? (value-now beh)) "<undefined>"]
|
||||
[(behavior? beh) (format "#<behavior (~a)>" (value-now beh))]
|
||||
[(event? beh) (format "#<event (last: ~a)>" (event-set-events (signal-value beh)))]
|
||||
[else beh]))
|
||||
|
||||
(define (render/dynamic-snip val super-render-fun)
|
||||
(if (behavior? val)
|
||||
; interesting case:
|
||||
; create a snip
|
||||
; each time val changes, recompute its rendering via super-render-fun
|
||||
(make-object dynamic-snip% val super-render-fun)
|
||||
; easy case
|
||||
(super-render-fun val)))
|
||||
|
||||
(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])
|
||||
(let ([c (read-char-or-special in)])
|
||||
(if (eof-object? c)
|
||||
(reverse (rest chars))
|
||||
(loop (cons c chars)))))))
|
||||
|
||||
(define (watch beh super-render-fun)
|
||||
(cond
|
||||
[(undefined? beh)
|
||||
(begin
|
||||
(make-object string-snip% "<undefined>")
|
||||
)
|
||||
]
|
||||
[(event? beh)
|
||||
(make-object value-snip% beh)]
|
||||
[(or (behavior? beh) (any-nested-reactivity? beh))
|
||||
(make-object dynamic-snip% (raise-reactivity beh) super-render-fun)]
|
||||
[(signal? beh)
|
||||
(make-object dynamic-snip% beh super-render-fun)]
|
||||
[else beh]))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
|
@ -1,94 +1,94 @@
|
|||
#lang scheme/base
|
||||
(require scheme/unit
|
||||
scheme/class
|
||||
scheme/bool
|
||||
mred
|
||||
(only-in mzlib/etc identity)
|
||||
scheme/list
|
||||
drscheme/tool
|
||||
string-constants)
|
||||
|
||||
(module frtime-tool mzscheme
|
||||
(require mzlib/unit
|
||||
mzlib/class
|
||||
mred
|
||||
mzlib/etc
|
||||
mzlib/list
|
||||
drscheme/tool
|
||||
string-constants)
|
||||
|
||||
(provide tool@)
|
||||
(provide tool@)
|
||||
|
||||
(define tool@
|
||||
(unit
|
||||
(import drscheme:tool^)
|
||||
(export drscheme:tool-exports^)
|
||||
|
||||
(define big-frtime-language%
|
||||
(class* object% (drscheme:language:simple-module-based-language<%>)
|
||||
(define/public (get-language-numbers)
|
||||
'(1000 -400))
|
||||
(define/public (get-language-position)
|
||||
(list (string-constant experimental-languages) "FrTime"))
|
||||
(define/public (get-module)
|
||||
'frtime/frtime-big)
|
||||
(define/public (get-one-line-summary)
|
||||
"Language for functional programming of event-driven systems")
|
||||
(define/public (get-language-url) #f)
|
||||
(define/public (get-reader)
|
||||
(lambda (name port)
|
||||
(let ([v (read-syntax name port)])
|
||||
(if (eof-object? v)
|
||||
v
|
||||
(namespace-syntax-introduce v)))))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define (weak-member obj lis)
|
||||
(let ([cmp (lambda (v) (eq? v obj))])
|
||||
(let loop ([lis lis])
|
||||
(and (cons? lis)
|
||||
(or
|
||||
(cond
|
||||
[(weak-box-value (first lis)) => cmp]
|
||||
[else false])
|
||||
(loop (rest lis)))))))
|
||||
|
||||
(define (watch watch-list value super-render-fun)
|
||||
(foldl
|
||||
(lambda (wb acc)
|
||||
(cond
|
||||
[(weak-box-value wb)
|
||||
=> (lambda (f) (f acc super-render-fun))]
|
||||
[else acc]))
|
||||
value
|
||||
watch-list))
|
||||
|
||||
(define (make-frtime-language base)
|
||||
(class (drscheme:language:module-based-language->language-mixin
|
||||
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
||||
base))
|
||||
(field (watch-list empty))
|
||||
(inherit get-language-position)
|
||||
(define/override (get-language-name)
|
||||
"FrTime")
|
||||
(define/override (on-execute settings run-in-user-thread)
|
||||
(let ([drs-eventspace (current-eventspace)])
|
||||
(super on-execute settings run-in-user-thread)
|
||||
(run-in-user-thread
|
||||
(lambda ()
|
||||
(let ([new-watch (namespace-variable-value 'watch)]
|
||||
[set-evspc (namespace-variable-value 'set-eventspace)])
|
||||
(set-evspc drs-eventspace)
|
||||
(set! watch-list
|
||||
((if (weak-member new-watch watch-list)
|
||||
identity
|
||||
(lambda (r) (cons (make-weak-box new-watch) r)))
|
||||
(filter weak-box-value watch-list))))))))
|
||||
|
||||
;; pass (lambda (v) (super render-value(/format) v settings width port))
|
||||
;; to watcher
|
||||
(override render-value/format render-value)
|
||||
(define (render-value/format value settings port width)
|
||||
(super render-value/format (watch watch-list value (lambda (v prt) (render-value/format v settings prt width)))
|
||||
settings port width))
|
||||
(define (render-value value settings port)
|
||||
(super render-value (watch watch-list value (lambda (v prt) (render-value settings prt)))
|
||||
settings port))
|
||||
(define/override (use-namespace-require/copy?) #t)
|
||||
(super-instantiate ())))
|
||||
|
||||
(define (phase1) (void))
|
||||
(define (phase2)
|
||||
(drscheme:language-configuration:add-language
|
||||
(make-object ((drscheme:language:get-default-mixin) (make-frtime-language big-frtime-language%))))))))
|
||||
(define tool@
|
||||
(unit
|
||||
(import drscheme:tool^)
|
||||
(export drscheme:tool-exports^)
|
||||
|
||||
(define big-frtime-language%
|
||||
(class* object% (drscheme:language:simple-module-based-language<%>)
|
||||
(define/public (get-language-numbers)
|
||||
'(1000 -400))
|
||||
(define/public (get-language-position)
|
||||
(list (string-constant experimental-languages) "FrTime"))
|
||||
(define/public (get-module)
|
||||
'frtime/frtime-big)
|
||||
(define/public (get-one-line-summary)
|
||||
"Language for functional programming of event-driven systems")
|
||||
(define/public (get-language-url) #f)
|
||||
(define/public (get-reader)
|
||||
(lambda (name port)
|
||||
(let ([v (read-syntax name port)])
|
||||
(if (eof-object? v)
|
||||
v
|
||||
(namespace-syntax-introduce v)))))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define (weak-member obj lis)
|
||||
(let ([cmp (lambda (v) (eq? v obj))])
|
||||
(let loop ([lis lis])
|
||||
(and (cons? lis)
|
||||
(or
|
||||
(cond
|
||||
[(weak-box-value (first lis)) => cmp]
|
||||
[else false])
|
||||
(loop (rest lis)))))))
|
||||
|
||||
(define (watch watch-list value super-render-fun)
|
||||
(foldl
|
||||
(lambda (wb acc)
|
||||
(cond
|
||||
[(weak-box-value wb)
|
||||
=> (lambda (f) (f acc super-render-fun))]
|
||||
[else acc]))
|
||||
value
|
||||
watch-list))
|
||||
|
||||
(define (make-frtime-language base)
|
||||
(class (drscheme:language:module-based-language->language-mixin
|
||||
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
||||
base))
|
||||
(field (watch-list empty))
|
||||
(inherit get-language-position)
|
||||
(define/override (get-language-name)
|
||||
"FrTime")
|
||||
(define/override (on-execute settings run-in-user-thread)
|
||||
(let ([drs-eventspace (current-eventspace)])
|
||||
(super on-execute settings run-in-user-thread)
|
||||
(run-in-user-thread
|
||||
(lambda ()
|
||||
(let ([new-watch (namespace-variable-value 'watch)]
|
||||
[set-evspc (namespace-variable-value 'set-eventspace)])
|
||||
(set-evspc drs-eventspace)
|
||||
(set! watch-list
|
||||
((if (weak-member new-watch watch-list)
|
||||
identity
|
||||
(lambda (r) (cons (make-weak-box new-watch) r)))
|
||||
(filter weak-box-value watch-list))))))))
|
||||
|
||||
;; pass (lambda (v) (super render-value(/format) v settings width port))
|
||||
;; to watcher
|
||||
(override render-value/format render-value)
|
||||
(define (render-value/format value settings port width)
|
||||
(super render-value/format (watch watch-list value (lambda (v prt) (render-value/format v settings prt width)))
|
||||
settings port width))
|
||||
(define (render-value value settings port)
|
||||
(super render-value (watch watch-list value (lambda (v prt) (render-value settings prt)))
|
||||
settings port))
|
||||
(define/override (use-namespace-require/copy?) #t)
|
||||
(super-instantiate ())))
|
||||
|
||||
(define (phase1) (void))
|
||||
(define (phase2)
|
||||
(drscheme:language-configuration:add-language
|
||||
(make-object ((drscheme:language:get-default-mixin) (make-frtime-language big-frtime-language%)))))))
|
||||
|
|
@ -1,72 +1,68 @@
|
|||
(module graphics-sig mzscheme
|
||||
(require mzlib/unit)
|
||||
#lang scheme
|
||||
(require scheme/unit)
|
||||
|
||||
(provide graphics^ graphics:posn-less^ graphics:posn^)
|
||||
|
||||
(define-signature graphics:posn^
|
||||
(make-posn posn? posn-x posn-y set-posn-x! set-posn-y!))
|
||||
|
||||
(define-signature graphics:posn-less^
|
||||
(viewport?
|
||||
|
||||
sixkey-value sixkey-shift sixkey-control sixkey-meta sixkey-alt
|
||||
|
||||
sixmouse-x sixmouse-y sixmouse-left? sixmouse-middle? sixmouse-right?
|
||||
sixmouse?
|
||||
make-sixmouse
|
||||
|
||||
open-graphics
|
||||
close-graphics
|
||||
graphics-open?
|
||||
|
||||
make-rgb
|
||||
rgb-blue rgb-red rgb-green
|
||||
change-color
|
||||
rgb?
|
||||
|
||||
open-viewport
|
||||
open-pixmap
|
||||
close-viewport
|
||||
|
||||
query-mouse-posn
|
||||
|
||||
viewport-mouse-events
|
||||
viewport-key-events
|
||||
|
||||
clear-viewport draw-viewport flip-viewport
|
||||
|
||||
draw-line clear-line flip-line
|
||||
draw-pixel clear-pixel flip-pixel
|
||||
get-pixel get-color-pixel test-pixel
|
||||
|
||||
draw-rectangle clear-rectangle flip-rectangle
|
||||
draw-arc draw-solid-arc
|
||||
draw-ellipse clear-ellipse flip-ellipse
|
||||
draw-polygon clear-polygon flip-polygon
|
||||
draw-solid-rectangle clear-solid-rectangle flip-solid-rectangle
|
||||
draw-solid-ellipse clear-solid-ellipse flip-solid-ellipse
|
||||
draw-solid-polygon clear-solid-polygon flip-solid-polygon
|
||||
|
||||
get-string-size
|
||||
|
||||
draw-string clear-string flip-string
|
||||
|
||||
draw-pixmap-posn
|
||||
draw-pixmap
|
||||
save-pixmap
|
||||
|
||||
copy-viewport
|
||||
|
||||
default-display-is-color?
|
||||
|
||||
viewport->snip
|
||||
|
||||
viewport-dc viewport-buffer-dc))
|
||||
|
||||
(define-signature graphics^
|
||||
((open graphics:posn-less^)
|
||||
(open graphics:posn^)))
|
||||
)
|
||||
(provide graphics^ graphics:posn-less^ graphics:posn^)
|
||||
|
||||
(define-signature graphics:posn^
|
||||
(make-posn posn? posn-x posn-y set-posn-x! set-posn-y!))
|
||||
|
||||
(define-signature graphics:posn-less^
|
||||
(viewport?
|
||||
|
||||
sixkey-value sixkey-shift sixkey-control sixkey-meta sixkey-alt
|
||||
|
||||
sixmouse-x sixmouse-y sixmouse-left? sixmouse-middle? sixmouse-right?
|
||||
sixmouse?
|
||||
make-sixmouse
|
||||
|
||||
open-graphics
|
||||
close-graphics
|
||||
graphics-open?
|
||||
|
||||
make-rgb
|
||||
rgb-blue rgb-red rgb-green
|
||||
change-color
|
||||
rgb?
|
||||
|
||||
open-viewport
|
||||
open-pixmap
|
||||
close-viewport
|
||||
|
||||
query-mouse-posn
|
||||
|
||||
viewport-mouse-events
|
||||
viewport-key-events
|
||||
|
||||
clear-viewport draw-viewport flip-viewport
|
||||
|
||||
draw-line clear-line flip-line
|
||||
draw-pixel clear-pixel flip-pixel
|
||||
get-pixel get-color-pixel test-pixel
|
||||
|
||||
draw-rectangle clear-rectangle flip-rectangle
|
||||
draw-arc draw-solid-arc
|
||||
draw-ellipse clear-ellipse flip-ellipse
|
||||
draw-polygon clear-polygon flip-polygon
|
||||
draw-solid-rectangle clear-solid-rectangle flip-solid-rectangle
|
||||
draw-solid-ellipse clear-solid-ellipse flip-solid-ellipse
|
||||
draw-solid-polygon clear-solid-polygon flip-solid-polygon
|
||||
|
||||
get-string-size
|
||||
|
||||
draw-string clear-string flip-string
|
||||
|
||||
draw-pixmap-posn
|
||||
draw-pixmap
|
||||
save-pixmap
|
||||
|
||||
copy-viewport
|
||||
|
||||
default-display-is-color?
|
||||
|
||||
viewport->snip
|
||||
|
||||
viewport-dc viewport-buffer-dc))
|
||||
|
||||
(define-signature graphics^
|
||||
((open graphics:posn-less^)
|
||||
(open graphics:posn^)))
|
||||
|
|
@ -1,15 +1,14 @@
|
|||
(module graphics-unit mzscheme
|
||||
(require mzlib/unit
|
||||
mred/mred-sig
|
||||
"graphics-sig.ss"
|
||||
"graphics-posn-less-unit.ss")
|
||||
(provide graphics@)
|
||||
#lang scheme
|
||||
(require scheme/unit
|
||||
mred/mred-sig
|
||||
"graphics-sig.ss"
|
||||
"graphics-posn-less-unit.ss")
|
||||
(provide graphics@)
|
||||
|
||||
(define-unit posn@ (import) (export graphics:posn^)
|
||||
(define-struct posn (x y)))
|
||||
|
||||
(define-compound-unit/infer graphics@
|
||||
(import mred^)
|
||||
(export graphics:posn^ graphics:posn-less^)
|
||||
(link posn@ graphics-posn-less@)))
|
||||
(define-unit posn@ (import) (export graphics:posn^)
|
||||
(define-struct posn (x y) #:mutable))
|
||||
|
||||
(define-compound-unit/infer graphics@
|
||||
(import mred^)
|
||||
(export graphics:posn^ graphics:posn-less^)
|
||||
(link posn@ graphics-posn-less@))
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
(module graphics mzscheme
|
||||
(require mzlib/unit
|
||||
mred/mred-sig
|
||||
mred
|
||||
"graphics-sig.ss"
|
||||
"graphics-unit.ss")
|
||||
(provide-signature-elements graphics:posn^ graphics:posn-less^)
|
||||
#lang scheme
|
||||
(require scheme/unit
|
||||
mred/mred-sig
|
||||
mred
|
||||
"graphics-sig.ss"
|
||||
"graphics-unit.ss")
|
||||
(provide-signature-elements graphics:posn^ graphics:posn-less^)
|
||||
|
||||
(define-values/invoke-unit/infer graphics@))
|
||||
(define-values/invoke-unit/infer graphics@)
|
||||
|
|
@ -1,115 +1,115 @@
|
|||
;; 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")
|
||||
|
||||
;; 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 module-identifier=? free-identifier=?)
|
||||
|
||||
(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)
|
||||
(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)
|
||||
(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)
|
||||
(let ([name (symbol->string (syntax-e id-stx))])
|
||||
(datum->syntax
|
||||
id-stx
|
||||
(string->symbol
|
||||
(format "~a~a" (syntax-e id-stx) lowered-equiv-suffix))))
|
||||
(substring name 0 (- (string-length name)
|
||||
(string-length lowered-equiv-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))
|
||||
;; Exception used to indicate that an expression cannot be lowered because
|
||||
;; it has no lowered equivalent.
|
||||
(define-struct exn:no-lowered-equiv (reason))
|
||||
|
||||
;; 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)
|
||||
(let ([name (symbol->string (syntax-e id-stx))])
|
||||
(datum->syntax-object
|
||||
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))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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)
|
||||
(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)
|
||||
(cons (cons new-func new-lowered-func)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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)
|
||||
(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)
|
||||
(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)
|
||||
(filter (lambda (pair)
|
||||
(not (module-identifier=? (car pair) func-to-remove)))
|
||||
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)
|
||||
(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)
|
||||
(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)
|
||||
(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)
|
||||
(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)))))))
|
||||
|
||||
;; 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
|
||||
(map (lambda (pair) (list (car pair) (cdr pair)))
|
||||
equiv-map)))
|
||||
;; 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))
|
||||
|
||||
;; 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)
|
||||
(foldl (lambda (func equiv-map)
|
||||
(if (lowered-equiv-id? func)
|
||||
(add-equiv-map
|
||||
equiv-map
|
||||
(lowered-equiv-id->lifted-id func) func)
|
||||
equiv-map))
|
||||
(empty-equiv-map)
|
||||
symbol-list))
|
||||
)
|
||||
;; 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)
|
||||
(let ([ret (lookup-lowered-equiv equiv-map func)])
|
||||
(if ret
|
||||
ret
|
||||
(raise (make-exn:no-lowered-equiv
|
||||
(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)
|
||||
(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 #'here
|
||||
(map (lambda (pair) (list (car pair) (cdr pair)))
|
||||
equiv-map)))
|
||||
|
||||
;; 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)
|
||||
(foldl (lambda (func equiv-map)
|
||||
(if (lowered-equiv-id? func)
|
||||
(add-equiv-map
|
||||
equiv-map
|
||||
(lowered-equiv-id->lifted-id func) func)
|
||||
equiv-map))
|
||||
(empty-equiv-map)
|
||||
symbol-list))
|
||||
Loading…
Reference in New Issue
Block a user