PasteRack.org
Paste # 83067
2020-07-09 15:51:10

Fork as a new paste.

Paste viewed 211 times.


Embed:

lefty gradebook grid

  1. #lang racket
  2.  
  3. (require 2htdp/image)
  4. (require lang/posn)
  5.  
  6. (define N-GRID-ROWS 42)
  7. (define N-RECTO-GRID-COLUMNS 17)
  8.  
  9. (define PX/PT 1)
  10.  
  11. ;; produces the number of pixels equivalent to n points
  12. (define (pt n) (* n PX/PT))
  13.  
  14.  
  15. (define CELL-W (pt 24))
  16. (define CELL-H (pt 24))
  17.  
  18. (define HEADER-ROW-H (pt 108))
  19.  ; how far the header line & number are rotated from horiz:
  20. (define HEADER-ROW-ANGLE 60)
  21. (define HEADER-LINE-LENGTH
  22.   (/ HEADER-ROW-H (sin (degrees->radians HEADER-ROW-ANGLE))))
  23.  
  24. (define HEADER-NUMERAL-SIZE (pt 9))
  25.  
  26. ;; Names column geometry
  27. (define NAMES-COLUMN-W (pt 72))
  28. (define NAMES-NUMERAL-SIZE (pt 8))
  29.  
  30. (define NAMES-ROW-ANGLE 30)
  31.  
  32. (define NAMES-COLUMN-LINE-LENGTH (/ NAMES-COLUMN-W (cos (degrees->radians NAMES-ROW-ANGLE))))
  33.  
  34. (define NAME-CELL-DIAGONAL-H
  35.   ;; vertical distance from bottom-left corner of a name cell to the right end of
  36.   ;; the bottom line of the cell
  37.   (* NAMES-COLUMN-LINE-LENGTH (sin (degrees->radians NAMES-ROW-ANGLE))))
  38. (define NAME-CELL-DIAGONAL-OVERLAP (- NAME-CELL-DIAGONAL-H CELL-H))
  39.  
  40. ;; Colors
  41.  
  42. (define GRID-BG-COLORS
  43.   ; lavenders
  44.   #;(list 'white
  45.         (make-color #xF0 #xE0 #xFF)
  46.         (make-color #xD0 #xC0 #xFF))
  47.   ; greens
  48.   (list 'white
  49.         (make-color #xF0 #xFF #xE0)
  50.         (make-color #xD0 #xFF #xC0)))
  51.  
  52. (define HEADER-LINE-COLOR 'forestgreen)
  53. (define GRID-LINE-COLOR (make-color 0 0 0 #x40))
  54. (define DARK-GRID-LINE-COLOR (make-color 0 0 0 #xA0))
  55. (define HEADER-NUMERAL-COLOR (make-color #x80 #x80 #x80 255))
  56. (define NAMES-NUMERAL-COLOR HEADER-NUMERAL-COLOR)
  57. (define HEADER-NUMERAL-OFFSET
  58.   (* CELL-W (cos (degrees->radians HEADER-ROW-ANGLE))))
  59.  
  60. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61. ;; Pinhole helper
  62.  
  63. ;; x-place y-place Image -> Image
  64. ;; places a pinhole on img at the location specified by x-place and y-place
  65. (define (align-pinhole x-place y-place img)
  66.   (put-pinhole (x-place->coordinate x-place img)
  67.                (y-place->coordinate y-place img)
  68.                img))
  69.  
  70. ;; x-place Image -> (Option Nat)
  71. ;; produces the x-coordinate for the given x-place in the image, or
  72. ;; #f if x-place is 'pinhole and img has no pinhole.
  73. (define (x-place->coordinate x-place img)
  74.   (define place (if (symbol? x-place) x-place (string->symbol x-place)))
  75.   (case place
  76.     [(left) 0]
  77.     [(right)         (image-width img)]
  78.     [(middle center) (exact-round (/ (image-width img) 2))]
  79.     [(pinhole)       (pinhole-x img)]))
  80.  
  81. ;; y-place Image -> (Option Nat)
  82. ;; produces the y-coordinate for the given y-place in the image, or
  83. ;; #f if y-place is 'pinhole and img has no pinhole.
  84. (define (y-place->coordinate y-place img)
  85.   (define place (if (symbol? y-place) y-place (string->symbol y-place)))
  86.   (case place
  87.     [(top)           0]
  88.     [(bottom)        (image-height img)]
  89.     [(middle center) (exact-round (/ (image-height img) 2))]
  90.     [(baseline) (error "FIXME need to implement baseline")]
  91.     [(pinhole) (pinhole-y img)]))
  92.  
  93. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  94. ;; Making numbered slanted headers
  95.  
  96. ;; Int+ -> Image
  97. ;; makes n header cells side-by-side, numbered R-to-L from 1 to n,
  98. ;; with a pinhole at the right end of the bottom line
  99. (define (number-headers n)
  100.   (put-pinhole (* n CELL-W) HEADER-ROW-H
  101.                (for/fold ([result empty-image])
  102.                          ([i (in-range 1 (add1 n))])
  103.                  (overlay/align/offset 'left 'bottom
  104.                                        (number-header i)
  105.                                        CELL-W 0
  106.                                        result))))
  107.  
  108. ;; Int+ -> Image
  109. ;; makes a header cell containing the number i
  110. (define (number-header i)
  111.   (define lines
  112.     (overlay/align 'left 'top
  113.                    (rotate (- HEADER-ROW-ANGLE) (line CELL-W 0 HEADER-LINE-COLOR))
  114.                    (line HEADER-LINE-LENGTH 0 HEADER-LINE-COLOR)))
  115.   (rotate HEADER-ROW-ANGLE
  116.           (overlay/align/offset 'left 'middle  lines HEADER-NUMERAL-OFFSET 0
  117.                                 (numeral i HEADER-NUMERAL-COLOR HEADER-NUMERAL-SIZE))))
  118.  
  119. ;; Nat Color Int+ -> Image
  120. ;; make an image of the given numeral, given color & point size font
  121. (define (numeral n c size) (cell-text (number->string n) c size))
  122.  
  123. ;; String Color Int+ -> Image
  124. ;; make an image of the given text, color & point size font
  125. (define (cell-text s c size)
  126.   (text/font s size c "Concourse T3 Tab" 'default 'normal 'normal #f))
  127.  
  128. (define ASSIGNMENTS-TITLE
  129.   (rotate HEADER-ROW-ANGLE
  130.           (put-pinhole 0 0 (above/align 'right
  131.                                         (line HEADER-LINE-LENGTH 0 HEADER-LINE-COLOR)
  132.                                         (cell-text "Asg" HEADER-NUMERAL-COLOR 11)))))
  133.  
  134. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  135. ;; Names column
  136.  
  137. ;; Int+ -> Image
  138. ;; makes n right-sidebar name cells, stacked vertically, numbered 1 to n
  139. ;; with a pinhole @ TL corner of the top cell
  140. (define (name-cells n)
  141.   (put-pinhole 0 NAME-CELL-DIAGONAL-H
  142.                (for/fold ([result empty-image])
  143.                          ([i (in-range 1 (add1 n))]
  144.                           [c (in-cycle GRID-BG-COLORS)])
  145.                  (overlay/align/offset 'left 'bottom
  146.                                        result
  147.                                        0 CELL-H
  148.                                        (name-cell i c)))))
  149.  
  150. ;; Int+ [Color] -> Image
  151. ;; makes a right-sidebar name cell containing the number i and given background color
  152. (define (name-cell i [bg-color 'white])
  153.   (overlay/align 'left 'bottom
  154.                  (beside/align 'top
  155.                                (line 0 CELL-H HEADER-LINE-COLOR)
  156.                                (rectangle 1 0 'solid 'white) ; FIXME magic #
  157.                                (numeral i HEADER-NUMERAL-COLOR NAMES-NUMERAL-SIZE))
  158.                  (rotate NAMES-ROW-ANGLE
  159.                          (line NAMES-COLUMN-LINE-LENGTH 0 HEADER-LINE-COLOR))
  160.                  (polygon (list (make-posn 0 NAME-CELL-DIAGONAL-OVERLAP) ; tl
  161.                                 (make-posn 0 NAME-CELL-DIAGONAL-H)  ; bl
  162.                                 (make-posn NAMES-COLUMN-W 0)
  163.                                 (make-posn NAMES-COLUMN-W (- CELL-H)))
  164.                           'solid bg-color)))
  165.  
  166. (define NAMES-TITLE
  167.   (align-pinhole 'left 'bottom
  168.                  (rotate NAMES-ROW-ANGLE
  169.                          (above/align 'right
  170.                                       (beside (cell-text "St." HEADER-NUMERAL-COLOR 11)
  171.                                               (rectangle 20 0 'solid 'white))
  172.                                       (line NAMES-COLUMN-LINE-LENGTH 0 HEADER-LINE-COLOR)))))
  173.  
  174. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  175. ;; Making a banded grid
  176.  
  177. ;; cell : Color -> Image
  178. ;; draw a bordered cell of given color
  179. (define (cell c)
  180.   (overlay (rectangle CELL-W CELL-H 'solid c)
  181.            (rectangle CELL-W CELL-H 'outline GRID-LINE-COLOR)))
  182.  
  183. ;; make an m-by-n grid of boxes (m cols, n rows), each CELL-W by CELL-H.
  184. ;; every col-group-size columns, there is a darker line on the left
  185. (define (grid m n [col-group-size 3])
  186.   (define col
  187.     (for/fold ([result empty-image])
  188.               ([c (in-cycle GRID-BG-COLORS)]
  189.                [i n])
  190.       (above result
  191.              (cell c))))
  192.  
  193.   (define (add-left-border img)
  194.     (overlay/align 'left 'top (line 0 (image-height col) DARK-GRID-LINE-COLOR) img))
  195.  
  196.   (define col-group (add-left-border (apply beside (make-list col-group-size col))))
  197.   (define n-groups (floor (/ m col-group-size)))
  198.   (define n-left (remainder m col-group-size))
  199.   (add-left-border
  200.    (cond
  201.      [(zero? n-groups)
  202.       (if (zero? n-left)
  203.           empty-image
  204.           (apply beside (make-list n-left col)))]
  205.      [(zero? n-left)
  206.       (apply beside (make-list n-groups col-group))]
  207.      [else
  208.       ;; the cons is bc beside requires 2+ args :P
  209.       (beside (apply beside (cons empty-image (make-list n-left col)))
  210.               (apply beside (cons empty-image (make-list n-groups col-group))))])))
  211.  
  212. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  213. ;; Gradebook recto page
  214.  
  215. (define (gradebook-recto m n)
  216.   (clear-pinhole
  217.    (overlay/pinhole (number-headers m)
  218.                     ASSIGNMENTS-TITLE
  219.                     (name-cells n)
  220.                     (align-pinhole 'right 'top (grid m n 3))
  221.                     NAMES-TITLE)))
  222.  
  223. (gradebook-recto 20 36)

=>

image