case/case.rkt

   1 #lang racket
   2 ;; Atreus case design mk 4
   3 ;; Copyright © 2019 Phil Hagelberg and contributors
   4 ;; released under the GPLv3 or later
   5
   6 (require xml)
   7
   8 ;; glowforge uses 96 dpi, 25.4 mm in an inch
   9 (define scale (/ 96 25.4))
  10 (define width 260)
  11 (define height 132)
  12
  13
  14 (define cols 6) ; per hand
  15 (define rows 4)
  16 (define angle (degrees->radians 10))
  17 (define corner-radius 6.0)
  18
  19 (define alps-switch-width 15.887)
  20 (define alps-switch-height 13.087)
  21 (define cherry-switch-width 13.62)
  22 (define cherry-switch-height 13.72)
  23 (define cherry? true)
  24 (define switch-height (if cherry? cherry-switch-height alps-switch-height))
  25 (define switch-width (if cherry? cherry-switch-width alps-switch-width))
  26
  27 (define switch-spacing 19.0)
  28
  29 (define screw-radius 1.642) ; for M3 screws
  30
  31 (define side-screw-distance (- (* switch-spacing (+ rows 1)) switch-height))
  32 (define bottom-screw-distance (- (* switch-spacing (+ cols 1)) switch-width))
  33 (define left corner-radius)
  34 (define bottom 95) ; outer bottom
  35 (define left-top (+ left (* side-screw-distance (sin angle))))
  36 (define top (- bottom (* side-screw-distance (cos angle))))
  37 (define right (- width corner-radius))
  38 (define right-top (- right (* side-screw-distance (sin angle))))
  39 (define mid-bottom (+ bottom (* bottom-screw-distance (sin angle))))
  40 (define mid-offset 25)
  41 (define mid-left (- (/ width 2) mid-offset))
  42 (define mid-right (+ (/ width 2) mid-offset))
  43
  44 (define hull-coords (list (list mid-right top)
  45                           (list right-top top)
  46                           (list right bottom)
  47                           (list mid-right mid-bottom)
  48                           (list mid-left mid-bottom)
  49                           (list left bottom)
  50                           (list left-top top)
  51                           (list mid-left top)))
  52
  53 ;;; screws
  54 (define screws
  55   `(g () ,@(for/list ([s (append (take hull-coords 3)
  56                                  ;; the bottom middle has only one screw but
  57                                  ;; two hull positions
  58                                  (list (list (/ width 2) mid-bottom))
  59                                  (drop hull-coords 5))])
  60              `(circle ((r ,(number->string screw-radius))
  61                        (cx ,(number->string (first s)))
  62                        (cy ,(number->string (second s))))))))
  63
  64 ;;; outline
  65 (define outline-coords (append hull-coords (take hull-coords 2)))
  66
  67 (define (to-next-screw? theta current-screw)
  68   (let* ([current (list-ref outline-coords current-screw)]
  69          [cx (first current)] [cy (second current)]
  70          [next (list-ref outline-coords (add1 current-screw))]
  71          [nx (first next)] [ny (second next)]
  72          [dx (- nx cx)] [dy (- ny cy)]
  73          [next-theta (- (radians->degrees (atan dy dx)))])
  74     (= (floor (modulo (floor next-theta) 180))
  75        (floor (modulo (- theta 90) 180)))))
  76
  77 ;; trace the outline by going from screw to screw until you've gone full-circle
  78 (define (outline-points coords theta current-screw)
  79   (if (< -360 (- theta 90) 360)
  80       (let* ([current (list-ref outline-coords current-screw)]
  81              [sx (first current)] [sy (second current)]
  82              [x (+ sx (* (cos (degrees->radians theta)) corner-radius))]
  83              [y (- sy (* (sin (degrees->radians theta)) corner-radius))]
  84              [coords (cons (format "~s,~s" x y) coords)])
  85         (if (to-next-screw? theta current-screw)
  86             (outline-points coords theta (add1 current-screw))
  87             (outline-points coords (sub1 theta) current-screw)))
  88       coords))
  89
  90 (define outline `(polygon
  91                   ((points ,(string-join (outline-points '() 90 0))))))
  92
  93 ;;; switches
  94
  95 (define column-offsets '(8 5 0 6 11 52))
  96
  97 (define (switch row col)
  98   (let* ([x (* (+ 1 col) switch-spacing)]
  99          [y (+ (list-ref column-offsets col) (* switch-spacing row))])
 100     `(rect ((height ,(number->string switch-height))
 101             (width ,(number->string switch-width))
 102             (x ,(number->string x))
 103             (y ,(number->string y))))))
 104
 105 (define hand-height (+ (* switch-spacing rows) (- switch-spacing switch-height)
 106                        (list-ref column-offsets 0)))
 107 (define switch-x-offset -6)
 108 (define switch-y-offset (- bottom hand-height))
 109
 110 (define switches
 111   `(g ((transform ,(format "translate(~s, ~s) rotate(~s, ~s, ~s)"
 112                            switch-x-offset switch-y-offset
 113                            (radians->degrees angle)
 114                            0 hand-height)))
 115       ,@(for/list ([col (in-range cols)]
 116                    #:when true
 117                    [row (if (= 5 col) '(0 1) (in-range rows))])
 118           (switch row col))))
 119
 120 (define switches-right
 121   `(g ((transform ,(format "translate(~s,~s) scale(-1, 1)" width 0)))
 122       ,switches))
 123
 124 (define doc
 125   (document (prolog '() false '())
 126             (xexpr->xml
 127              `(svg ((xmlns:svg "http://www.w3.org/2000/svg")
 128                     (height ,(number->string (* height scale)))
 129                     (width ,(number->string (* width scale))))
 130                    (g ((transform ,(format "scale(~s, ~s)" scale scale))
 131                        (stroke-width "1")
 132                        (stroke "black")
 133                        (fill-opacity "0"))
 134                       ,screws
 135                       ,outline
 136                       ,switches
 137                       ,switches-right
 138                       )))
 139             '()))
 140
 141 (call-with-output-file "case-mk4.svg"
 142   (lambda (out)
 143     (display "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>" out)
 144     (display-xml doc out))
 145   #:exists 'replace)