169 lines
3.8 KiB
Racket
169 lines
3.8 KiB
Racket
#lang racket
|
|
(require slideshow/pict
|
|
slideshow)
|
|
|
|
(define (pict->snip p [scale-factor 5])
|
|
(pict->bitmap
|
|
(scale p scale-factor)))
|
|
|
|
(define (left-bracket content-height line-width bracket-width)
|
|
(define h content-height)
|
|
(define bw bracket-width)
|
|
(define lw line-width)
|
|
(hc-append
|
|
(filled-rectangle lw h)
|
|
(vl-append (filled-rectangle bw lw)
|
|
(blank bw (- h (* 2 lw)))
|
|
(filled-rectangle bw lw))))
|
|
|
|
(define (right-bracket content-height line-width bracket-width)
|
|
(define h content-height)
|
|
(define bw bracket-width)
|
|
(define lw line-width)
|
|
(hc-append
|
|
(vl-append (filled-rectangle bw lw)
|
|
(blank bw (- h (* 2 lw)))
|
|
(filled-rectangle bw lw))
|
|
(filled-rectangle lw h)))
|
|
|
|
;;; Combiners
|
|
|
|
(define (over p q)
|
|
(vc-append -4 q p))
|
|
|
|
(define (under p q)
|
|
(vc-append p q))
|
|
|
|
(define (left p q)
|
|
(hc-append q p))
|
|
|
|
(define (right p q)
|
|
(hc-append p q))
|
|
|
|
(define (subscript p q)
|
|
(hb-append p (scale q 5/12)))
|
|
|
|
(define (superscript p q)
|
|
(ht-append p (scale q 5/12)))
|
|
|
|
|
|
(define (fraction p q)
|
|
(define w (max (pict-width p) (pict-width q)))
|
|
(vc-append p (hc-append (blank 1 0) (hline w 1) (blank 1 0)) q))
|
|
|
|
;;; Elements depending on one pict
|
|
|
|
(define (vector-arrow p)
|
|
(arrow (pict-width p) 0))
|
|
|
|
(define (bar p)
|
|
(define w (pict-width p))
|
|
(clip-descent
|
|
(hc-append (blank 1 0)
|
|
(hline w 1)
|
|
(blank 1 0))))
|
|
|
|
;;; Combination
|
|
|
|
(define (add f c p)
|
|
; (add bar over p) will put a bar over p
|
|
(c p (f p)))
|
|
|
|
;;;
|
|
|
|
|
|
(define (add-brackets p)
|
|
(define lw 1)
|
|
(define bw 5)
|
|
(define h (pict-height p))
|
|
(hc-append
|
|
(left-bracket h lw bw)
|
|
p
|
|
(right-bracket h lw bw)))
|
|
|
|
|
|
(define (build-array-pict m n f)
|
|
(apply hc-append
|
|
(add-between
|
|
(for/list ([j (in-range n)])
|
|
(apply vr-append
|
|
(for/list ([i (in-range m)])
|
|
(let ([f_ij (f i j)])
|
|
(cond
|
|
[(number? f_ij)
|
|
(text (number->string f_ij))]
|
|
[(pict? f_ij) f_ij]
|
|
[(string? f_ij)
|
|
(text f_ij)]
|
|
[else (error)])))))
|
|
(blank 5))))
|
|
|
|
(require racket/gui/base)
|
|
(define (butt-hline w)
|
|
(dc
|
|
(λ (dc dx dy)
|
|
(define pen (send dc get-pen))
|
|
(send dc set-pen (send the-pen-list find-or-create-pen
|
|
(send pen get-color)
|
|
(send pen get-width)
|
|
'solid
|
|
'butt))
|
|
(send dc draw-line dx dy (+ dx w) dy)
|
|
(send dc set-pen pen))
|
|
w 1))
|
|
|
|
|
|
|
|
(define (left-paren p)
|
|
(define w (max 5 (ceiling (/ (pict-height p) 10))))
|
|
(define h (pict-height p))
|
|
(dc
|
|
(λ (dc dx dy)
|
|
(define pen (send dc get-pen))
|
|
(send dc set-pen
|
|
(send the-pen-list find-or-create-pen
|
|
(send pen get-color)
|
|
(send pen get-width)
|
|
'solid
|
|
'butt))
|
|
(send dc draw-arc (+ dx (/ w 2)) dy w h (/ pi 2) (* 3/2 pi))
|
|
(send dc set-pen pen))
|
|
w h))
|
|
|
|
(define (right-paren p)
|
|
(define w (max 5 (ceiling (/ (pict-height p) 10))))
|
|
(define h (pict-height p))
|
|
(dc
|
|
(λ (dc dx dy)
|
|
(define pen (send dc get-pen))
|
|
(send dc set-pen
|
|
(send the-pen-list find-or-create-pen
|
|
(send pen get-color)
|
|
(send pen get-width)
|
|
'solid
|
|
'butt))
|
|
(send dc draw-arc (- dx (/ w 2)) dy w h (* 3/2 pi) (/ pi 2))
|
|
(send dc set-pen pen))
|
|
w h))
|
|
|
|
(define (add-paren p)
|
|
(hc-append (left-paren p) p (right-paren p)))
|
|
|
|
;;; TESTS
|
|
|
|
; A 4x4 matrix
|
|
|
|
(scale
|
|
(add-brackets
|
|
(build-array-pict
|
|
4 4 (λ (i j) (subscript (text "a") (text (format "~a~a" i j))))))
|
|
5)
|
|
|
|
; bars
|
|
(scale (add bar over (text "a")) 5)
|
|
|
|
; fraction
|
|
(scale (fraction (text "x") (text "y")) 5)
|
|
|
|
|