[ create a new paste ] login | about

Link: http://codepad.org/xNVvQKjM    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Feb 10:
;  years, months, days

(define-syntax (define-structure x)
  (define (gen-id template-id . args)
    (datum->syntax-object template-id
      (string->symbol
        (apply string-append
               (map (lambda (x)
                      (if (string? x) x
                        (symbol->string
                            (syntax-object->datum x))))
                    args)))))
  (syntax-case x ()
    ((_ name field ...)
     (with-syntax
       ((constructor (gen-id (syntax name) "make-" (syntax name)))
        (predicate (gen-id (syntax name) (syntax name) "?"))
        ((access ...)
          (map (lambda (x) (gen-id x (syntax name) "-" x))
               (syntax (field ...))))
        ((assign ...)
          (map (lambda (x) (gen-id x "set-" (syntax name) "-" x "!"))
               (syntax (field ...))))
        (structure-length (+ (length (syntax (field ...))) 1))
        ((index ...) (let f ((i 1) (ids (syntax (field ...))))
                       (if (null? ids) '()
                         (cons i (f (+ i 1) (cdr ids)))))))
    (syntax (begin
              (define (constructor field ...)
                (vector 'name field ...))
              (define (predicate x)
                (and (vector? x)
                     (= (vector-length x) structure-length)
                     (eq? (vector-ref x 0) 'name)))
              (define (access x) (vector-ref x index)) ...
              (define (assign x update) (vector-set! x index update))
              ...))))))

(define-structure date year month day)

(define (lt? date1 date2)
  (cond ((< (date-year date1) (date-year date2)) #t)
        ((< (date-year date2) (date-year date1)) #f)
        ((< (date-month date1) (date-month date2)) #t)
        ((< (date-month date2) (date-month date1)) #f)
        (else (< (date-day date1) (date-day date2)))))

(define (leap? year)
  (if (zero? (modulo year 100))
      (zero? (modulo year 400))
      (zero? (modulo year 4))))

(define (between lo hi)
  (if (lt? hi lo) (between hi lo)
    (let ((borrows (vector 31 31 28 31 30 31 30 31 31 30 31 30)))
      (when (leap? (date-year hi)) (vector-set! borrows 2 29))
      (when (< (date-day hi) (date-day lo))
        (set-date-day! hi
          (+ (date-day hi)
             (vector-ref borrows (- (date-month hi) 1))))
        (set-date-month! hi (- (date-month hi) 1)))
      (when (< (date-month hi) (date-month lo))
        (set-date-month! hi (+ (date-month hi) 12))
        (set-date-year! hi (- (date-year hi) 1)))
      (values (- (date-year hi) (date-year lo))
              (- (date-month hi) (date-month lo))
              (- (date-day hi) (date-day lo))))))


Create a new paste based on this one


Comments: