PasteRack.org
Paste # 70507
2015-01-24 14:19:37

Fork as a new paste.

Paste viewed 731 times.


Embed:

  1. #lang racket
  2.  
  3. (require srfi/1)
  4. (require racket/gui/base pict)
  5. (require racket/draw)
  6. (require 2htdp/batch-io)
  7. (require mrlib/path-dialog)
  8. (require racket/math)
  9. (require math/matrix)
  10.  
  11. ;; definitions
  12. (define supported-types '("LWPOLYLINE" "ARC" "POINT" "CIRCLE" "LINE"))
  13. ;(define supported-types '("LWPOLYLINE"))
  14. (define entity-types '("3DFACE"  "3DSOLID"  "ACAD_PROXY_ENTITY" "ARC" "ARCALIGNEDTEXT"  "ATTDEF"  "ATTRIB"  "BODY"  "CIRCLE" "DIMENSION" "ELLIPSE"  "HATCH" "IMAGE"  "INSERT"  "LEADER"  "LINE" "LWPOLYLINE" "MLINE"  "MTEXT"  "OLEFRAME"  "OLE2FRAME"  "POINT" "POLYLINE" "RAY"  "REGION"  "RTEXT"  "SEQEND"  "SHAPE"  "SOLID" "SPLINE" "TEXT"  "TOLERANCE"  "TRACE"  "VERTEX"  "VIEWPORT" "WIPEOUT" "XLINE"))
  15. (define sections (list "ENTITIES" "ENDSEC"))
  16. (define file-list '())
  17. (define section-list '())
  18. (define entity-list '())
  19. (define struct-list '())
  20. (define search-list '())
  21. (define list-of-layers '())
  22. (define select-box '())
  23. (define display-select-box #f)
  24. (define new-scale '())
  25.  
  26. ;; gui definitions
  27. (define editor-frame-width 800)
  28. (define editor-frame-height 600)
  29. (define globalx-offset 0)
  30. (define base-offset (- editor-frame-height 150))
  31. (define globaly-offset base-offset)
  32. (define global-x-scale 1)
  33. (define global-y-scale -1)
  34. (define dimension-scale 0) ;scale the dimensions of the shape in DXF file to fit the current frame dimensions
  35. (define transformation-matrix (vector 1 0 0 1 0 0))
  36. (define rotation 0)
  37. (define init-x 0)
  38. (define init-y 0)
  39. (define left 0)
  40. (define bottom 0)
  41.  
  42. ;; parsing functions
  43. (define (split str [ptn #rx"[ ]+"])
  44.   (regexp-split ptn (string-trim str)))
  45. (define (reader input-port)
  46.   (define lines (read-chunks input-port))
  47.   (foldl (lambda (f r)
  48.            (define fst (filter (compose not (curry string=? "")) (split f)))
  49.            (append fst r))
  50.          '() lines))
  51. (define (read-chunks input-port)
  52.   (let loop ([accu '()])
  53.     (define nxt (read-line input-port 'any))
  54.     (if (eof-object? nxt)
  55.         ((lambda (x) x) accu)
  56.         (loop (cons nxt accu)))))
  57.  
  58. ;; extract the values in one section into a list
  59. (define (extract-section lst header)
  60.   (define (extract-until lst keyword)
  61.     (cond ((equal? (car lst) keyword) '())
  62.           (else (cons (car lst) (extract-until (cdr lst) keyword)))))
  63.   (extract-until (member (car header) lst) (cadr header)))
  64.  
  65. (define (separate-entities lst)
  66.   (if (empty? lst)
  67.       '()
  68.       (let-values ([(data tail) (break (lambda (element) (member element entity-types)) (rest lst))])
  69.         (if (member (first lst) supported-types)
  70.             (begin (cons (cons (first lst) data)
  71.                          (separate-entities tail)))
  72.             (separate-entities tail)))))
  73.  
  74. (define noob '())
  75.  
  76. ;; change a single list containing entity information into a struct list
  77. (define (entity-list->struct-list lst)
  78.   (define (string-contains-alphabet? str)
  79.     (ormap char-alphabetic? (string->list str)))
  80.   (define (take-pair lst)
  81.     (cond ((> 2 (length lst)) '())
  82.           (else (cons (list (first lst)
  83.                             (if (string-contains-alphabet? (second lst)) (second lst) (string->number (second lst))))
  84.                       (take-pair (cddr lst))))))
  85.   (define (filter-header lst key)
  86.     (cond ((empty? lst) '())
  87.           ((member (car (car lst)) key)
  88.            (cons (car lst)
  89.                  (filter-header (cdr lst) key)))
  90.           (else
  91.            (filter-header (cdr lst) key))))
  92.   ; 1) if 70 = 1 or 129 then closed. store x y value
  93.   ; 2) create line for 10 20 10 20
  94.   ; 3) create arc for 10 20 42 10 20
  95.   (define (separate-lwpolyline lst layer)
  96.     (define (closed-polyline lst first-x first-y)
  97.       (match lst
  98. ;        [(list (list "10" x1) (list "20" y1) (list "42" bulge) (list "10" x2) (list "20" y2))        (create-arc2 layer x1 y1 x2 y2 bulge)]
  99. ;        [(list (list "10" x1) (list "20" y1) (list "10" x2) (list "20" y2))                          (create-line layer x1 y1 x2 y2)]
  100.         [(list (list "10" x1) (list "20" y1) (list "42" bulge) (list "10" x2) (list "20" y2) a ...)  (cons (create-arc2 layer x1 y1 x2 y2 bulge) (closed-polyline (append (list (list "10" x2) (list "20" y2)) a) first-x first-y))]
  101.         [(list (list "10" x1) (list "20" y1) (list "10" x2) (list "20" y2) a ...)                    (cons (create-line layer x1 y1 x2 y2) (closed-polyline (append (list (list "10" x2) (list "20" y2)) a) first-x first-y))]
  102.         [(list (list "10" x1) (list "20" y1) (list "42" bulge))                                      (create-arc2 layer x1 y1 first-x first-y bulge)]
  103.         [(list (list "10" x1) (list "20" y1))                                                        (create-line layer x1 y1 first-x first-y)]
  104.         [_ (void)]))
  105.     (define (open-polyline lst)
  106.       (match lst
  107.         [(list (list "10" x1) (list "20" y1) (list "42" bulge) (list "10" x2) (list "20" y2))        (create-arc2 layer x1 y1 x2 y2 bulge)]
  108.         [(list (list "10" x1) (list "20" y1) (list "10" x2) (list "20" y2))                          (create-line layer x1 y1 x2 y2)]
  109.         [(list (list "10" x1) (list "20" y1) (list "42" bulge) (list "10" x2) (list "20" y2) a ...)  (cons (create-arc2 layer x1 y1 x2 y2 bulge) (open-polyline (append (list (list "10" x2) (list "20" y2)) a)))]
  110.         [(list (list "10" x1) (list "20" y1) (list "10" x2) (list "20" y2) a ...)                    (cons (create-line layer x1 y1 x2 y2) (open-polyline (append (list (list "10" x2) (list "20" y2)) a)))]
  111.         [(list (list "10" x1) (list "20" y1) (list "42" bulge))                                      (display "error, there should not be a 42 point at the end of an open polyline")]
  112.         [_ (void)]))
  113.     (let* ((polyline-flag (cadr (findf (lambda (x) (equal? (car x) "70")) lst)))
  114.            (closed? (if (equal? polyline-flag (or 1 129)) #t #f))
  115.            (first-x (cadr (findf (lambda (x) (equal? (car x) "10")) lst)))
  116.            (first-y (cadr (findf (lambda (x) (equal? (car x) "20")) lst)))) ;1 or 129 for closed, 0 for open
  117.       (if closed?
  118.           (closed-polyline (cdr lst) first-x first-y)
  119.           (open-polyline (cdr lst)))))
  120.   (map (lambda (x) (case (car x)
  121.                      [("LINE")       (apply create-line        (map cadr (filter-header (take-pair (cdr x)) '("8" "10" "20" "11" "21"))))]
  122.                      [("LWPOLYLINE") (separate-lwpolyline
  123.                                       (filter-header (take-pair (cdr x)) '("70" "10" "20" "42"))
  124.                                       (cadr (car (filter-header (take-pair (cdr x)) '("8")))))]
  125.                      [("CIRCLE")     (apply create-circle      (map cadr (filter-header (take-pair (cdr x)) '("8" "10" "20" "40"))))]
  126.                      [("POINT")      (apply create-point       (map cadr (filter-header (take-pair (cdr x)) '("8" "10" "20"))))]
  127.                      [("ARC")        (apply create-arc         (map cadr (filter-header (take-pair (cdr x)) '("8" "10" "20" "40" "50" "51"))))]))
  128.        lst))
  129.  
  130. ;create entity and struct list when opening new file
  131. (define (open-file input-port)
  132.   (set! file-list (reader (open-input-file input-port)))
  133.   (set! section-list (extract-section file-list sections))
  134.   (set! entity-list (separate-entities section-list))
  135.   (set! struct-list (flatten (entity-list->struct-list entity-list)))
  136.   (update-layer-list struct-list)
  137.   (get-scales struct-list)
  138.   (set! new-scale (car (get-scales struct-list)))
  139.   (set! left (cadr (get-scales struct-list)))
  140.   (set! bottom (caddr (get-scales struct-list)))
  141.   (set! search-list (rescale struct-list (get-scales struct-list)))
  142.   (display-layers))
  143.  
  144. ;; struct definitions
  145. (struct entity (layer [selected #:auto #:mutable] [visible #:auto #:mutable]) #:auto-value #f)
  146. (struct line entity (x1 y1 x2 y2) #:transparent)
  147. (struct point entity (x y))
  148. (struct arc entity (x y radius start end) #:transparent)
  149.  
  150. ;; geometric functions
  151. (define (point-in-rect? x y xs ys xb yb)
  152.   (and (> x xs) (< x xb) (> y ys) (< y yb)))
  153.  
  154. ;; auxilliary functions
  155. (define (best fn lst)
  156.   (unless (empty? lst)
  157.     (let ((wins (car lst)))
  158.       (for/list ([i (cdr lst)])
  159.         (when (fn i wins)
  160.           (set! wins i)))
  161.       wins)))
  162.  
  163. (define (biggest lst)
  164.   (best > lst))
  165.  
  166. (define (smallest lst)
  167.   (best < lst))
  168.  
  169. ;; this is used to check the equality of two numbers to a set decimal point
  170. ;; 0.009 -> accuracy up to 2 decimal point.
  171. ;; 0.09 -> accuracy up to 1 decimal point.
  172. ;; 0.9 -> integer test.
  173. ;; test up to 3 decimal points.
  174. (define (reasonable-equal? x y)
  175.   (<= (abs (- x y)) 0.000009))
  176.  
  177. (define (in-between? test-num num-1 num-2)
  178.   (or (and (> num-1 test-num) (< num-2 test-num))
  179.       (and (> num-2 test-num) (< num-1 test-num))))
  180.  
  181. ;; pass intersect? the start and end point of select box and the struct-list
  182. ;; it will traverse the struct-list to see if any elements
  183. (define (intersect? x1 y1 x2 y2 struct-lst)
  184.   (let ((big-x (biggest (list x1 x2)))
  185.         (big-y (biggest (list y1 y2)))
  186.         (small-x (smallest (list x1 x2)))
  187.         (small-y (smallest (list y1 y2))))
  188.     (for/list ([i struct-lst])
  189.       ;only calculate intersections for visible and not yet selected items
  190.       (when (and (entity-visible i) (not (entity-selected i)))
  191.         (when (line? i)
  192.           (when (cohen-sutherland i small-x small-y big-x big-y) (set-entity-selected! i #t)))
  193.         (when (arc? i)
  194.           (when (arc-intersect? i small-x small-y big-x big-y) (set-entity-selected! i #t)))
  195.         (when (point? i)
  196.           (when (point-in-rect? (point-x i) (point-y i) small-x small-y big-x big-y) (set-entity-selected! i #t)))))))
  197.  
  198. ;; these 3 functions calculate the x and y coordinates for arc points
  199. (define (arc-point-x circle-x degree radius)
  200.   (let ((adjusted (localize-degree degree)))
  201.     (cond ((or (= degree 90) (= degree 270)) circle-x)
  202.           ((= degree 180) (- circle-x radius))
  203.           ((or (= degree 360) (= degree 0)) (+ circle-x radius))
  204.           ((in-between? degree 0 90)    (+ circle-x (* radius (cos (degrees->radians adjusted)))))
  205.           ((in-between? degree 90 180)  (- circle-x (* radius (sin (degrees->radians adjusted)))))
  206.           ((in-between? degree 180 270) (- circle-x (* radius (cos (degrees->radians adjusted)))))
  207.           ((in-between? degree 270 360) (+ circle-x (* radius (sin (degrees->radians adjusted)))))
  208.           (else (display "error")))))
  209. (define (arc-point-y circle-y degree radius)
  210.   (let ((adjusted (localize-degree degree)))
  211.     (cond ((or (= degree 0) (= degree 360) (= degree 180)) circle-y)
  212.           ((= degree 90) (+ circle-y radius))
  213.           ((= degree 270) (- circle-y radius))
  214.           ((in-between? degree 0 90)    (+ circle-y (* radius (sin (degrees->radians adjusted)))))
  215.           ((in-between? degree 90 180)  (+ circle-y (* radius (cos (degrees->radians adjusted)))))
  216.           ((in-between? degree 180 270) (- circle-y (* radius (sin (degrees->radians adjusted)))))
  217.           ((in-between? degree 270 360) (- circle-y (* radius (cos (degrees->radians adjusted)))))
  218.           (else (display "error")))))
  219. (define (localize-degree degree)
  220.   (cond ((in-between? degree 0 90) degree)
  221.         ((in-between? degree 90 180) (- degree 90))
  222.         ((in-between? degree 180 270) (- degree 180))
  223.         ((in-between? degree 270 360) (- degree 270))))
  224.  
  225. ;; 1) check for the trivial case - the arc point is inside the select box
  226. ;; 2) imagine the 4 lines of the select box as an infinite line, do they intersect the circle of the arc?
  227. ;; 2.1) if they do, are they in the select box's actual length/width?
  228. ;; 2.2) if they are, does it intersect the arc?
  229. ;; 2.3.1) arc intersection is checked by comparing the points where the lines intersect the circle.
  230. ;; 2.3.2) imagine a line from arc point 1 to arc point 2 as a "dividing line", to differentiate points intersecting the circle on the "right" or "wrong" side of the arc
  231. ;; 2.3.3) calculate the mid-point of the arc to determine the "right" side of the arc.
  232. ;; 2.3.4) imagine a line that goes through the mid-point of the arc and is parallel to the "dividing line" (hence they have the same slope).
  233. ;; 2.3.5) is the y-intercept bigger or smaller than the y-intercept of the dividing line? use that as a barometer for any point intersecting the circle.
  234. ;; 2.3.6) if the line formed with the intersecting point falls on the right side of the "dividing line" together with the line formed with the mid-point line, then there is an intersection.
  235. (define (arc-intersect? arc-struct xs ys xb yb)
  236.   (let* ((radius (arc-radius arc-struct))
  237.          (circle-x (arc-x arc-struct))
  238.          (circle-y (arc-y arc-struct))
  239.          (start (arc-start arc-struct))
  240.          (end (arc-end arc-struct))
  241.          (angle-difference (if (> end start) (- end start) (+ (- 360 start) end)))
  242.          (half-angle (if (> end start) (/ (+ start end) 2) (if (< 360 (+ 180 (/ (+ start end) 2))) (- (+ 180 (/ (+ start end) 2)) 360) (+ 180 (/ (+ start end) 2)))))
  243.          (radius (arc-radius arc-struct))
  244.          (arc-x1 (arc-point-x circle-x start radius))
  245.          (arc-y1 (arc-point-y circle-y start radius))
  246.          (arc-x2 (arc-point-x circle-x end radius))
  247.          (arc-y2 (arc-point-y circle-y end radius))
  248.          ;we calculate the middle arc-point to determine which is the right side
  249.          (half-x (arc-point-x circle-x half-angle radius))
  250.          (half-y (arc-point-y circle-y half-angle radius)))
  251.     (define (right-side-y? x y)
  252.       (let* ((dividing-line-slope       (/ (- arc-y2 arc-y1) (- arc-x2 arc-x1)))
  253.              (dividing-line-yintercept  (- arc-y1 (* dividing-line-slope arc-x1)))
  254.              (right-yintercept          (- half-y (* dividing-line-slope half-x)))
  255.              (right-value-test          (> right-yintercept dividing-line-yintercept))
  256.              (point-yintercept          (- y (* dividing-line-slope x)))
  257.              (point-test                (> point-yintercept dividing-line-yintercept)))
  258.         (eq? right-value-test point-test)))
  259.     (define (line-intersect-arc? x1 y1 x2 y2)
  260.       ;return the point where line intersects arc. intersection of a y line with a circle, 2 possible x values
  261.       (define (yline-intersect-circle? y)
  262.         (let ((result1 (+ circle-x (sqrt (- (expt radius 2) (expt (- y circle-y) 2)))))
  263.               (result2 (- circle-x (sqrt (- (expt radius 2) (expt (- y circle-y) 2))))))
  264.           (if (real? result1)
  265.               (cond ((and (in-between? result1 xs xb) (in-between? result2 xs xb))
  266.                      (list (list result1 y) (list result2 y)))
  267.                     ((in-between? result1 xs xb)
  268.                      (list (list result1 y)))
  269.                     ((in-between? result2 xs xb)
  270.                      (list (list result2 y)))
  271.                     (else #f))
  272.               #f)))
  273.       ;return the point where line intersects arc. intersection of a x line with a circle, 2 possible y values
  274.       (define (xline-intersect-circle? x)
  275.         (let ((result1 (+ circle-y (sqrt (- (expt radius 2) (expt (- x circle-x) 2)))))
  276.               (result2 (- circle-y (sqrt (- (expt radius 2) (expt (- x circle-x) 2))))))
  277.           (if (real? result1)
  278.               (cond ((and (in-between? result1 ys yb) (in-between? result2 ys yb))
  279.                      (list (list x result1) (list x result2)))
  280.                     ((in-between? result1 ys yb)
  281.                      (list (list x result1)))
  282.                     ((in-between? result2 ys yb)
  283.                      (list (list x result2)))
  284.                     (else #f))
  285.               #f)))
  286.       (if (= x1 x2)
  287.           ((lambda (x) (if (eq? x #f) #f (ormap (lambda (a) (apply right-side-y? a)) x))) (xline-intersect-circle? x1))    ;is a x line, find y values
  288.           ((lambda (x) (if (eq? x #f) #f (ormap (lambda (a) (apply right-side-y? a)) x))) (yline-intersect-circle? y1))))  ;is a y line, find x values
  289.     (cond ((or (point-in-rect? arc-x1 arc-y1 xs ys xb yb) (point-in-rect? arc-x2 arc-y2 xs ys xb yb)) #t)
  290.           ((or (line-intersect-arc? xs ys xs yb)
  291.                (line-intersect-arc? xs yb xb yb)
  292.                (line-intersect-arc? xb yb xb ys)
  293.                (line-intersect-arc? xb ys xs ys)) #t)
  294.           (else #f))))
  295.  
  296. ;; divide the complete 2d space into 9 boxes
  297. ;; algorithm to detect line-rectangle intersection. separate 2d area into 9 rectangles where 0 represents the selected area
  298. ;; region numbers are bit->decimal
  299. ;; 9   1   5                1001   0001   0101
  300. ;; 8   0   4      --->      1000   0000   0100
  301. ;; 10  2   6                1010   0010   0110
  302. (define (cohen-sutherland line-struct xs ys xb yb)
  303.   (let ((lx1 (line-x1 line-struct))
  304.         (ly1 (line-y1 line-struct))
  305.         (lx2 (line-x2 line-struct))
  306.         (ly2 (line-y2 line-struct)))
  307.     (define (compute-outcode x y)
  308.       (let ((inside 0))
  309.         (cond ((< x xs)
  310.                (set! inside (bitwise-ior inside 1)))
  311.               ((> x xb)
  312.                (set! inside (bitwise-ior inside 2))))
  313.         (cond ((< y ys)
  314.                (set! inside (bitwise-ior inside 4)))
  315.               ((> y yb)
  316.                (set! inside (bitwise-ior inside 8))))
  317.         inside))
  318.     ;return #t if intersect
  319.     (define (trivial-accept? region1 region2)
  320.       (or (not (bitwise-ior region1 region2))
  321.           (= region1 0)
  322.           (= region2 0)
  323.           (and (= region1 1) (= region2 2))
  324.           (and (= region1 2) (= region2 1))
  325.           (and (= region1 4) (= region2 8))
  326.           (and (= region1 8) (= region2 4))))
  327.     ;return #t if does not intersect
  328.     (define (trivial-reject? region1 region2)
  329.       (not (= (bitwise-and region1 region2) 0)))
  330.     ;clip until no more ambiguous cases
  331.     (define (clip-until region1 region2 tries)
  332.       (cond ((= tries 0) #f)
  333.             ((trivial-reject? region1 region2) #f)
  334.             ((trivial-accept? region1 region2) #t)
  335.             (else (apply clip-until (append (do-clip region1 region2) (list (- tries 1)))))))
  336.     (define (do-clip region1 region2)
  337.       (define (not0 num)
  338.         (if (= num 0) #f #t))
  339.       (let* ((new-x 0)
  340.              (new-y 0)
  341.              (slope (/ (- ly2 ly1) (- lx2 lx1)))
  342.              (y-intercept (- ly2 (* slope lx2))))
  343.         ;apply the formula y = y1 + slope * (x - x1), x = x1 + (y - y1) / slope
  344.         (cond ((not0 (bitwise-and 8 region2))
  345.                (set! new-x (/ (- yb y-intercept) slope))
  346.                (set! new-y yb))
  347.               ((not0 (bitwise-and 4 region2))
  348.                (set! new-x (/ (- ys y-intercept) slope))
  349.                (set! new-y ys))
  350.               ((not0 (bitwise-and 2 region2))
  351.                (set! new-x xb)
  352.                (set! new-y (+ (* slope xb) y-intercept)))
  353.               ((not0 (bitwise-and 1 region2))
  354.                (set! new-x xs)
  355.                (set! new-y (+ (* slope xs) y-intercept))))
  356.         (set! lx2 new-x)
  357.         (set! ly2 new-y)
  358.         (set! region2 (compute-outcode lx2 ly2)))
  359.       (list region1 region2))
  360.     (let* ((region1 (compute-outcode lx1 ly1))
  361.            (region2 (compute-outcode lx2 ly2)))
  362.       (clip-until region1 region2 4))))
  363.  
  364. ;; creation functions
  365. (define (layer->string x)
  366.   (if (string? x) x (number->string x)))
  367.  
  368. ;; 1) determine the center point of the arc given the angle and the 2 arc points.
  369. ;; 1.1) calculate the 2 possible center points using vectors. the 2 arc points form a line/chord.
  370. ;; 1.2) a perpendicular line bisecting the line/chord at the midpoint with a magnitude (calculated using trigonometry) extending in either direction are the 2 possible center points.
  371. ;; 1.3) the arc goes from the first to the second point in a CW or CCW fashion depending on the sign of the bulge (-ve bulge means CW fashion, +ve means CCW fashion)
  372. ;; 1.41) if the angle (calculated using the bulge) is smaller than 180, then for a CW arc, the centerpoint is CCW with respect to the vector formed from arc point 1 to arc point 2
  373. ;; 1.42) if the angle (calculated using the bulge) is bigger than 180, then for a CW arc, the centerpoint is CW with respect to the vector formed from arc point 1 to arc point 2
  374. ;; 2) determine the quadrant where the first arc point is located by separating the bounding box of the circle (with the center points and radius) into 4 areas.
  375. ;; 3) calculate the angle from start point to x axis.
  376. ;; 4) when creating an arc from DXF files, the arcs go from start angle to end angle in a clockwise fashion. we want to represent that here.
  377. (define (create-arc2 layer x1 y1 x2 y2 bulge)
  378.   (define (get-center angle big-bulge?)
  379.     (let* ((chord-length (sqrt (+ (expt (- x1 x2) 2) (expt (- y1 y2) 2))))
  380.            (small-angle (if (< angle pi) angle (- (* 2 pi) angle)))
  381.            ;negative bulge indicates point 1 goes to point 2 in a CW fashion
  382.            (is-cw? (negative? bulge))
  383.            (radius (abs (/ (/ chord-length 2) (sin (/ small-angle 2)))))
  384.            (midpoint-x (/ (+ x1 x2) 2))
  385.            (midpoint-y (/ (+ y1 y2) 2))
  386.            ;normalizing a vector -> calculate length, then divide each of its xy components by its length
  387.            (vector-x (- x1 x2))
  388.            (vector-y (- y1 y2))
  389.            (magnitude chord-length)
  390.            (unit-vector-x (* vector-x (/ 1 magnitude)))
  391.            (unit-vector-y (* vector-y (/ 1 magnitude)))
  392.            ;the normal is perpendicular to the vector formed by the 2 arc points
  393.            (normal-vector-x (* 1 unit-vector-y))
  394.            (normal-vector-y (* -1 unit-vector-x))
  395.            (adj (/ (/ chord-length 2) (tan (/ angle 2))))
  396.            ;2 possible center points
  397.            (center1-x (+ midpoint-x (* adj normal-vector-x)))
  398.            (center1-y (+ midpoint-y (* adj normal-vector-y)))
  399.            (center2-x (- midpoint-x (* adj normal-vector-x)))
  400.            (center2-y (- midpoint-y (* adj normal-vector-y)))
  401.            (ax1 (radians->degrees (cos (/ (- x1 center2-x) radius))))
  402.            (ax2 (radians->degrees (cos (/ (- x2 center2-x) radius))))
  403.            (cross-product1 (- (* (- x2 x1) (- center1-y y1)) (* (- y2 y1) (- center1-x x1))))
  404.            (cross-product2 (- (* (- x2 x1) (- center2-y y1)) (* (- y2 y1) (- center2-x x1)))))
  405.       (if big-bulge?
  406.           (if is-cw?                         ;big angle -> CW center and CW arc or CCW center and CCW arc
  407.               (if (positive? cross-product1) ;positive cross product means center is CW with respect to point1 -> point 2
  408.                   (list center1-x center1-y radius)
  409.                   (list center2-x center2-y radius))
  410.               (if (negative? cross-product2)
  411.                   (list center2-x center2-y radius)
  412.                   (list center1-x center1-y radius)))
  413.           (if is-cw?                         ;small angle -> CW center and CCW arc or CCW center and CW arc
  414.               (if (positive? cross-product1) ;positive cross product means center is CW with respect to point1 -> point 2
  415.                   (list center2-x center2-y radius)
  416.                   (list center1-x center1-y radius))
  417.               (if (negative? cross-product2)
  418.                   (list center1-x center1-y radius)
  419.                   (list center2-x center2-y radius))))))
  420.   (let* ((arc-angle-rad (abs (* 4 (atan bulge))))
  421.          (big-bulge? (> arc-angle-rad pi))
  422.          (small-angle (if (< arc-angle-rad pi) arc-angle-rad (- (* 2 pi) arc-angle-rad)))
  423.          (is-cw? (negative? bulge))
  424.          (centerpoints (get-center arc-angle-rad big-bulge?))
  425.          (center-x (car centerpoints))
  426.          (center-y (cadr centerpoints))
  427.          (radius (caddr centerpoints))
  428.          (top (+ center-y radius))
  429.          (bottom (- center-y radius))
  430.          (left (- center-x radius))
  431.          (right (+ center-x radius))
  432.          (quad-num (cond ((and (in-between? x1 left center-x) (in-between? y1 top center-y)) 2)
  433.                          ((and (in-between? x1 left center-x) (in-between? y1 bottom center-y)) 3)
  434.                          ((and (in-between? x1 right center-x) (in-between? y1 top center-y)) 1)
  435.                          ((and (in-between? x1 right center-x) (in-between? y1 bottom center-y)) 4)
  436.                          ;0 is for edge cases.
  437.                          ((or (reasonable-equal? x1 left) (reasonable-equal? x1 right) (reasonable-equal? y1 top) (reasonable-equal? y1 bottom)) 0)
  438.                          (else (display "unaccounted for"))))
  439.          (angle-to (acos (/ (abs (- x1 center-x)) radius)))
  440.          (start (radians->degrees (cond ((= quad-num 0)
  441.                                          (cond ((reasonable-equal? x1 left) (degrees->radians 180))
  442.                                                ((reasonable-equal? x1 right) (degrees->radians 0))
  443.                                                ((reasonable-equal? y1 top) (degrees->radians 90))
  444.                                                ((reasonable-equal? y1 bottom) (degrees->radians 270))
  445.                                                (else (display "unaccounted for"))))
  446.                                         ((= quad-num 1) angle-to)
  447.                                         ((= quad-num 2) (- (degrees->radians 180) angle-to))
  448.                                         ((= quad-num 3) (+ (degrees->radians 180) angle-to))
  449.                                         ((= quad-num 4) (- (degrees->radians 360) angle-to)))))
  450.          (end (if is-cw?
  451.                   (if (negative? (- start (radians->degrees arc-angle-rad)))
  452.                       (+ 360 (- start (radians->degrees arc-angle-rad)))
  453.                       (- start (radians->degrees arc-angle-rad)))
  454.                   (if (< 360 (+ start (radians->degrees arc-angle-rad)))
  455.                       (- (+ start (radians->degrees arc-angle-rad)) 360)
  456.                       (+ start (radians->degrees arc-angle-rad))))))
  457.     ;DXF is CW
  458.     (list (if is-cw?
  459.               (create-arc layer center-x center-y radius end start)
  460.               (create-arc layer center-x center-y radius start end)))))
  461.  
  462. (define (create-line layer x1 y1 x2 y2)
  463.   (line (layer->string layer) x1 y1 x2 y2))
  464.  
  465. (define (create-point layer x y)
  466.   (point (layer->string layer) x y))
  467.  
  468. (define (create-arc layer x y radius start end)
  469.   (arc (layer->string layer) x y radius start end))
  470.  
  471. (define (create-circle layer x y radius) ; creating 2 semicircles with create-arc
  472.   (create-arc (layer->string layer) x y radius 0 360))
  473.  
  474. ;;; scaling functions
  475. (define (get-all-x struct-lst)
  476.   (flatten (for/list ([i struct-lst])
  477.              (match i
  478.                [(line layer selected visible x1 y1 x2 y2)         (list x1 x2)]
  479.                [(arc layer selected visible x y radius start end) (list (+ x radius) (- x radius))]
  480.                [(point layer selected visible x y)
  481.                 (list x)]))))
  482. (define (get-all-y struct-lst)
  483.   (flatten (for/list ([i struct-lst])
  484.              (match i
  485.                [(line layer selected visible x1 y1 x2 y2)         (list y1 y2)]
  486.                [(arc layer selected visible x y radius start end) (list (+ y radius) (- y radius))]
  487.                [(point layer selected visible x y)                (list y)]))))
  488.  
  489. ;; return the scales
  490. (define (get-scales struct-lst)
  491.   (let* ((top (biggest (get-all-y struct-lst)))
  492.          (bottom (smallest (get-all-y struct-lst)))
  493.          (left (smallest (get-all-x struct-lst)))
  494.          (right (biggest (get-all-x struct-lst)))
  495.          (height (abs (- top bottom)))
  496.          (width (abs (- right left)))
  497.          (x-scale (/ editor-frame-width width))
  498.          (y-scale (/ editor-frame-height height))
  499.          (new-scale (smallest (list x-scale y-scale))))
  500.     (list new-scale left bottom)))
  501.  
  502. (define (rescale struct-lst scale-lst)
  503.   (let ((new-scale (car scale-lst)))
  504.     (flatten (for/list ([i struct-lst])
  505.                (match i
  506.                  [(line layer selected visible x1 y1 x2 y2)         (line layer (scale-x-coord x1) (scale-y-coord y1) (scale-x-coord x2) (scale-y-coord y2))]
  507.                  [(arc layer selected visible x y radius start end) (arc layer (scale-x-coord x) (scale-y-coord y) (* new-scale radius) start end)]
  508.                  [(point layer selected visible x y)                (point layer (scale-x-coord x) (scale-y-coord y))])))))
  509.  
  510. (define (scale-x-coord coord)
  511.   (* new-scale (- coord left)))
  512. (define (scale-y-coord coord)
  513.   (* new-scale (- coord bottom)))
  514.  
  515. ;; drawing functions
  516. (define (draw-point x y selected)
  517.   (if selected
  518.       (send drawer set-pen red-pen)
  519.       (send drawer set-pen normal-pen))
  520.   (send drawer draw-point x y))
  521.  
  522. (define (draw-line x1 y1 x2 y2 selected)
  523.   (if selected
  524.       (send drawer set-pen red-pen)
  525.       (send drawer set-pen normal-pen))
  526.   (send drawer draw-line x1 y1 x2 y2))
  527.  
  528. ;; racket's draw-arc function's x,y starts at bottom left corner (docs say top left but inverted because of -ve y-scale)
  529. ;; DXF provided arc x,y coordinates are at the center of the arc/circle
  530. (define (draw-arc x y radius start end selected)
  531.   (if selected
  532.       (send drawer set-pen red-pen)
  533.       (send drawer set-pen normal-pen))
  534.   (let ((convert-angle1 (degrees->radians (- 360 start))) ;; DXF angles are CW, Racket angles are CCW (because of inverting y scale)
  535.         (convert-angle2 (degrees->radians (- 360 end)))
  536.         (start-x (- x radius))
  537.         (start-y (- y radius)))
  538.     (send drawer draw-arc start-x start-y (* 2 radius) (* 2 radius) convert-angle2 convert-angle1)))
  539.  
  540. (define (draw-objects lst) ;get a struct-list.
  541.   (define (apply-procedure x)
  542.     (when (entity-visible x)
  543.       (match x
  544.         [(line layer selected visible x1 y1 x2 y2)         (draw-line x1 y1 x2 y2 selected)]
  545.         [(arc layer selected visible x y radius start end) (draw-arc x y radius start end selected)]
  546.         [(point layer selected visible x y)                (draw-point x y selected)])))
  547.   (map apply-procedure lst))
  548.  
  549. ;; gui control/frame definitions
  550. (define top-frame (new frame%
  551.                        [label "KR"]
  552.                        [width editor-frame-width]
  553.                        [height editor-frame-height]
  554.                        [alignment (list 'left 'top)]))
  555.  
  556. (define menu-bar (new menu-bar%
  557.                       (parent top-frame)))
  558.  
  559. (define file (new menu%
  560.                   (label "&File")
  561.                   (parent menu-bar)))
  562.  
  563. (new menu-item%
  564.      (label "&Open.. ")
  565.      (parent file)
  566.      (callback (lambda (b e)
  567.                  (open-file (send open run)))))
  568.  
  569. (define open (new path-dialog%
  570.                   [existing? #t]
  571.                   [filters (list (list "DXF Files" "*.dxf") (list "Text Files" "*.txt"))]))
  572.  
  573. (define my-canvas%
  574.   (class canvas%
  575.     (override on-char)
  576.     (define on-char (lambda (event)
  577.                       (let ((key (send event get-key-code)))
  578.                         (special-control-key #t)
  579.                         (case key
  580.                           ['wheel-up    (set! global-x-scale (+ global-x-scale 0.2)) (set! global-y-scale (- global-y-scale 0.2))
  581.                                         (send drawer set-transformation (vector transformation-matrix globalx-offset globaly-offset global-x-scale global-y-scale rotation))]
  582.                           ['escape      (map (lambda (x) (set-entity-selected! x #f)) search-list)]
  583.                           ['wheel-down  (set! global-x-scale (- global-x-scale 0.2)) (set! global-y-scale (+ global-y-scale 0.2))
  584.                                         (send drawer set-transformation (vector transformation-matrix globalx-offset globaly-offset global-x-scale global-y-scale rotation))]
  585.                           ['#\backspace (map (lambda (x) (when (entity-selected x) (set-entity-visible! x #f) (set-entity-selected! x #f))) search-list)]))
  586.                       (send canvas refresh)))
  587.     (define/override (on-event event)
  588.       (define x (send event get-x))
  589.       (define y (send event get-y))
  590.       ;; scale the x and y values.
  591.       (define (scalex-to-display x)
  592.         (/ (- x globalx-offset) global-x-scale))
  593.       (define (scaley-to-display y)
  594.         (/ (- y globaly-offset) global-y-scale))
  595.       (define scaled-x (scalex-to-display (send event get-x)))
  596.       (define scaled-y (scaley-to-display (send event get-y)))
  597.       (cond
  598.         ((and (send event button-down? 'left) (send event get-caps-down))
  599.          (set! init-x scaled-x)
  600.          (set! init-y scaled-y)
  601.          (set! display-select-box #t))
  602.         ((and (send event button-up? 'left) (send event get-caps-down))
  603.          (set! display-select-box #f)
  604.          (intersect? init-x init-y scaled-x scaled-y search-list)
  605.          (send canvas refresh))
  606.         ((and (send event dragging?) (send event get-caps-down))
  607.          (set! select-box (list (list init-x init-y scaled-x init-y #t)
  608.                                 (list scaled-x init-y scaled-x scaled-y #t)
  609.                                 (list scaled-x scaled-y init-x scaled-y #t)
  610.                                 (list init-x scaled-y init-x init-y #t)))
  611.          (send canvas refresh))
  612.         ((send event button-down? 'left)
  613.          (set! init-x x)
  614.          (set! init-y y)
  615.          (display (list scaled-x scaled-y x y)))
  616.         ((send event button-up? 'left)
  617.          (set! globalx-offset (vector-ref (send drawer get-transformation) 1))
  618.          (set! globaly-offset (vector-ref (send drawer get-transformation) 2)))
  619.         ((send event dragging?)
  620.          (let* ((current-x (- x init-x))
  621.                 (current-y (- y init-y)))
  622.            (send drawer set-transformation (vector transformation-matrix (+ current-x globalx-offset) (+ current-y globaly-offset) global-x-scale global-y-scale rotation))
  623.            (send canvas refresh)))))
  624.     (super-instantiate ())))
  625.  
  626. (define canvas (new my-canvas%
  627.                     [parent top-frame]
  628.                     ;[style (list 'hscroll 'vscroll 'resize-corner)]
  629.                     [paint-callback (lambda (canvas dc)
  630.                                       (send drawer set-brush no-brush)
  631.                                       (when display-select-box (draw-select-box select-box))
  632.                                       (draw-objects search-list)
  633.                                       (send drawer set-pen normal-pen)
  634.                                       )]))
  635.  
  636. (define button (new button%
  637.                     [label "Refocus"]
  638.                     [parent top-frame]
  639.                     [callback (lambda (b e)
  640.                                 (set! globalx-offset 0)
  641.                                 (set! globaly-offset base-offset)
  642.                                 (set! global-x-scale 1)
  643.                                 (set! global-y-scale -1)
  644.                                 (send drawer set-transformation (vector transformation-matrix globalx-offset globaly-offset global-x-scale global-y-scale rotation))
  645.                                 (send canvas on-paint)
  646.                                 (send canvas refresh))]))
  647.  
  648. (define (draw-select-box lst)
  649.   (for/list ([i lst])
  650.     (apply draw-line i)))
  651.  
  652. (define (update-layer-list struct-list)
  653.   (set! list-of-layers (map (lambda (x) (if (string? x) x (number->string x)))
  654.                             (remove-duplicates (map entity-layer struct-list))))) ;layers as numbers changed to string
  655.  
  656. (define (display-layers)
  657.   (map (lambda (x) (when (is-a? x check-box%) (send top-frame delete-child x)))
  658.        (send top-frame get-children)) ;delete all existing check-boxes
  659.   (for/list ([i list-of-layers])
  660.     (new check-box%
  661.          (label i)
  662.          (parent top-frame)
  663.          (callback (lambda (checked e)
  664.                      (if (send checked get-value)
  665.                          (map (lambda (k) (when (equal? (entity-layer k) i) (set-entity-visible! k #t) (set-entity-selected! k #f))) search-list)
  666.                          (map (lambda (k) (when (equal? (entity-layer k) i) (set-entity-visible! k #f))) search-list))
  667.                      (draw-objects search-list)
  668.                      (send canvas on-paint)
  669.                      (send canvas refresh-now))))))
  670.  
  671. (define no-brush (new brush% [style 'transparent]))
  672. (define red-pen (new pen% [color "red"] [width 2]))
  673. (define normal-pen (new pen% [color "black"] [width 1]))
  674. (define drawer (send canvas get-dc))
  675.  
  676. (foldl set-entity-visible! #t struct-list)
  677. (send top-frame show #t)
  678. (send drawer set-transformation (vector transformation-matrix globalx-offset globaly-offset global-x-scale global-y-scale rotation))
  679. (sleep/yield 0.1)

=>