Skip to content

Instantly share code, notes, and snippets.

@Xophmeister

Xophmeister/q.rkt

Created September 29, 2020 16:23
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save Xophmeister/23523387708ae0aef1013b19b7f2f501 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save Xophmeister/23523387708ae0aef1013b19b7f2f501 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. Xophmeister created this gist Sep 29, 2020.
    111 changes: 111 additions & 0 deletions q.rkt
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,111 @@
    #lang racket/base

    (require racket/contract
    racket/match
    racket/math)


    (define numerator/c exact-integer?)
    (define denominator/c (and/c exact-integer? (not/c zero?)))
    (define Q/c (->i ((msg (symbols 'p 'q '->exact)))
    (result (msg) (match msg ('p numerator/c)
    ('q denominator/c)
    ('->exact exact?)))))

    (provide/contract
    (Q (-> numerator/c denominator/c Q/c))
    (Q+ (-> Q/c ... Q/c))
    (Q* (-> Q/c ... Q/c))
    (Q- (-> Q/c Q/c ... Q/c))
    (Q/ (-> Q/c Q/c ... Q/c))

    (half Q/c)
    (third Q/c)
    (quarter Q/c)
    (fifth Q/c)
    (sixth Q/c)
    (seventh Q/c)
    (eighth Q/c)
    (ninth Q/c)
    (tenth Q/c)
    (sixteenth Q/c))


    (define (Q p q)
    (let* ((s (* (sgn p) (sgn q))) ; Sign
    (p+ (abs p)) ; Absolute numerator
    (q+ (abs q)) ; Absolute denominator
    (d (gcd p+ q+))
    (P (* s (/ p+ d))) ; Signed, normalised numerator
    (Q (/ q+ d))) ; Normalised denominator

    (lambda (msg)
    (match msg ('p P)
    ('q Q)
    ('->exact (/ P Q))))))


    (define Q+
    (lambda values
    (foldl (lambda (a b) (Q (+ (* (a 'p) (b 'q)) (* (a 'q) (b 'p)))
    (* (a 'q) (b 'q))))
    zero values)))


    (define Q*
    (lambda values
    (foldl (lambda (a b) (Q (* (a 'p) (b 'p))
    (* (a 'q) (b 'q))))
    one values)))


    (define Q-
    (lambda values
    (match values
    ((list x) (Q- zero x))
    ((list-rest x xs) (apply Q+ x (map (lambda (x) (Q (* -1 (x 'p)) (x 'q))) xs))))))


    (define Q/
    (lambda values
    (match values
    ((list x) (Q/ one x))
    ((list-rest x xs) (apply Q* x (map (lambda (x) (Q (x 'q) (x 'p))) xs))))))


    (define zero (Q 0 1))
    (define one (Q 1 1))
    (define half (Q 1 2))
    (define third (Q 1 3))
    (define quarter (Q 1 4))
    (define fifth (Q 1 5))
    (define sixth (Q 1 6))
    (define seventh (Q 1 7))
    (define eighth (Q 1 8))
    (define ninth (Q 1 9))
    (define tenth (Q 1 10))
    (define sixteenth (Q 1 16))


    (module+ test
    (require rackunit)

    (check-equal? (zero '->exact) 0)
    (check-equal? (one '->exact) 1)
    (check-equal? (half '->exact) 1/2)
    (check-equal? (third '->exact) 1/3)
    (check-equal? (quarter '->exact) 1/4)
    (check-equal? (fifth '->exact) 1/5)
    (check-equal? (sixth '->exact) 1/6)
    (check-equal? (seventh '->exact) 1/7)
    (check-equal? (eighth '->exact) 1/8)
    (check-equal? (ninth '->exact) 1/9)
    (check-equal? (tenth '->exact) 1/10)
    (check-equal? (sixteenth '->exact) 1/16)

    (check-equal? ((Q+ half quarter eighth sixteenth sixteenth) '->exact) 1)
    (check-equal? ((Q* half quarter eighth) '->exact) 1/64)
    (check-equal? ((Q- one) '->exact) -1)
    (check-equal? ((Q- one half quarter) '->exact) 1/4)
    (check-equal? ((Q/ half) '->exact) 2)
    (check-equal? ((Q/ one half quarter) '->exact) 8))