1#lang racket/base 2(require mred 3 mzlib/class 4 racket/format) 5 6(provide define-accessor 7 define/provide-struct 8 adjust-keyword-default 9 seconds->hhmmss) 10 11(define-syntax define-accessor 12 (syntax-rules () 13 [(_ margin get-margin extra-arg ...) 14 (define-syntax margin 15 (syntax-id-rules () 16 [(margin arg (... ...)) ((get-margin extra-arg ...) arg (... ...))] 17 [margin (get-margin extra-arg ...)]))])) 18 19(define-syntax define/provide-struct 20 (syntax-rules () 21 [(_ id flds flags ...) 22 (begin 23 (define-struct id flds flags ...) 24 (provide (struct-out id)))])) 25 26 27(define (seconds->hhmmss s) 28 (define-values (hours left) (quotient/remainder s (* 60 60))) 29 (define-values (minutes seconds) (quotient/remainder left 60)) 30 (string-append 31 (~r hours #:min-width 2 #:pad-string "0") ":" 32 (~r minutes #:min-width 2 #:pad-string "0") ":" 33 (~r seconds #:min-width 2 #:pad-string "0"))) 34 35(define (adjust-keyword-default proc kw kw-val) 36 (define-values (req opt) (procedure-keywords proc)) 37 (procedure-reduce-keyword-arity 38 (make-keyword-procedure 39 (lambda (kws kw-vals . args) 40 (if (memq kw kws) 41 (keyword-apply proc kws kw-vals args) 42 (keyword-apply-with-keyword proc kw kw-val kws kw-vals args)))) 43 (procedure-arity proc) 44 req 45 opt)) 46 47(define (keyword-apply-with-keyword proc kw kw-val kws kw-vals args) 48 (let loop ([kws kws] [kw-vals kw-vals] [rev-kws '()] [rev-kw-vals '()]) 49 (cond 50 [(or (null? kws) 51 (keyword<? kw (car kws))) 52 (define new-kws (append (reverse rev-kws) (list kw) kws)) 53 (define new-kw-vals (append (reverse rev-kw-vals) (list kw-val) kw-vals)) 54 (keyword-apply proc new-kws new-kw-vals args)] 55 [else 56 (loop (cdr kws) (cdr kw-vals) (cons (car kws) rev-kws) (cons (car kw-vals) rev-kw-vals))]))) 57