If it is possible I would like some comments on the overall style of the program. It feels like I am writing the whole program as one big script and I'm not sure how to break it down into several compact modules. Also, I feel like I'm writing the program like I do in VB.NET because of the global variables. Any comments on how to improve the program structure would be appreciated.
#lang racket
(require srfi/1)
(require racket/gui/base pict)
(require racket/draw)
(require 2htdp/batch-io)
(require mrlib/path-dialog)
;; definitions
(define supported-types '("LWPOLYLINE" "ARC" "POINT" "CIRCLE" "LINE"))
;(define supported-types '("LWPOLYLINE"))
(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"))
(define sections (list "ENTITIES" "ENDSEC"))
(define file-list '())
(define section-list '())
(define entity-list '())
(define struct-list '())
(define current-display '())
(define list-of-layers '())
(define select-box '())
(define display-select-box #f)
;; gui definitions
(define editor-frame-width 800)
(define editor-frame-height 600)
(define globalx-offset 200)
(define globaly-offset 400)
(define x-scale 1)
(define y-scale -1)
(define dimension-scale 0) ;scale the dimensions of the shape in DXF file to fit the current frame dimensions
(define transformation-matrix (vector 1 0 0 1 0 0))
(define rotation 0)
(define init-x 0)
(define init-y 0)
;; parsing functions
(define (split str [ptn #rx"[ ]+"])
(regexp-split ptn (string-trim str)))
(define (reader input-port)
(define lines (read-chunks input-port))
(foldl (lambda (f r)
(define fst (filter (compose not (curry string=? "")) (split f)))
(append fst r))
'() lines))
(define (read-chunks input-port)
(let loop ([accu '()])
(define nxt (read-line input-port 'any))
(if (eof-object? nxt)
((lambda (x) x) accu)
(loop (cons nxt accu)))))
;; extract the values in one section into a list
(define (extract-section lst header)
(define (extract-until lst keyword)
(cond ((equal? (car lst) keyword) '())
(else (cons (car lst) (extract-until (cdr lst) keyword)))))
(extract-until (member (car header) lst) (cadr header)))
(define (separate-entities lst)
(if (empty? lst)
'()
(let-values ([(data tail) (break (lambda (element) (member element entity-types)) (rest lst))])
(if (member (first lst) supported-types)
(begin (cons (cons (first lst) data)
(separate-entities tail)))
(separate-entities tail)))))
;; change a single list containing entity information into a struct list
(define (entity-list->struct-list lst)
(define (string-contains-alphabet? str)
(ormap char-alphabetic? (string->list str)))
(define (take-pair lst)
(cond ((> 2 (length lst)) '())
(else (cons (list (first lst)
(if (string-contains-alphabet? (second lst)) (second lst) (string->number (second lst))))
(take-pair (cddr lst))))))
(define (filter-header lst key)
(cond ((empty? lst) '())
((member (car (car lst)) key)
(cons (car lst)
(filter-header (cdr lst) key)))
(else
(filter-header (cdr lst) key))))
(define (separate-lwpolyline lst layer)
(cond ((= 3 (length lst))
'())
((= 4 (length lst))
(apply create-line layer (map cadr lst)))
((= 42 (cadr (third lst)))
'()
(separate-lwpolyline (cddr lst) layer))
(else
(cons (apply create-line layer (map cadr (take lst 4)))
(separate-lwpolyline (cddr lst) layer)))))
(map (lambda (x) (case (car x)
[("LINE") (apply create-line (map cadr (filter-header (take-pair (cdr x)) '("8" "10" "20" "11" "21"))))]
[("LWPOLYLINE") (separate-lwpolyline
(filter-header (take-pair (cdr x)) '("10" "20" "42"))
(cadr (car (filter-header (take-pair (cdr x)) '("8")))))]
[("CIRCLE") (apply create-circle (map cadr (filter-header (take-pair (cdr x)) '("8" "10" "20" "40"))))]
[("POINT") (apply create-point (map cadr (filter-header (take-pair (cdr x)) '("8" "10" "20"))))]
[("ARC") (apply create-arc (map cadr (filter-header (take-pair (cdr x)) '("8" "10" "20" "40" "50" "51"))))]))
lst))
;create entity and struct list when opening new file
(define (open-file input-port)
(set! file-list (reader (open-input-file input-port)))
(set! section-list (extract-section file-list sections))
(set! entity-list (separate-entities section-list))
(set! struct-list (flatten (entity-list->struct-list entity-list)))
(update-layer-list struct-list)
(display-layers))
; (initialize-display)
;; struct definitions
(struct entity (layer [selected #:auto #:mutable] [visible #:auto #:mutable]) #:auto-value #f)
(struct line entity (x1 y1 x2 y2))
(struct point entity (x y))
(struct arc entity (x y radius start end))
;; geometric functions
(define (point-in-rect? x y xs ys xb yb)
(and (> x xs) (< x xb) (> y ys) (< y yb)))
;; auxilliary functions
(define (best fn lst)
(unless (empty? lst)
(let ((wins (car lst)))
(for/list ([i (cdr lst)])
(when (fn i wins)
(set! wins i)))
wins)))
(define (biggest lst)
(best > lst))
(define (smallest lst)
(best < lst))
(define (in-between? test-num num-1 num-2)
(let ((big (biggest (list num-1 num-2)))
(small (smallest (list num-1 num-2))))
(and (eq? big (biggest (list test-num big)))
(eq? small (smallest (list test-num small))))))
;; pass intersect? the start and end point of select box and the struct-list
;; it will traverse the struct-list to see if any elements
(define (intersect? x1 y1 x2 y2 struct-lst)
(let ((big-x (biggest (list x1 x2)))
(big-y (biggest (list y1 y2)))
(small-x (smallest (list x1 x2)))
(small-y (smallest (list y1 y2))))
(for/list ([i struct-lst])
(when (line? i)
(when (cohen-sutherland i small-x small-y big-x big-y) (set-entity-selected! i #t)))
(when (arc? i)
(when (arc-intersect? i small-x small-y big-x big-y) (set-entity-selected! i #t)))
(when (point? i)
(when (point-in-rect? (point-x i) (point-y i) small-x small-y big-x big-y) (set-entity-selected! i #t))))))
;; to determine if arc is selected,
;; 1) check for a trivial accept case - any of the 2 arc point is inside the select box
;; 2) if arc is bigger than 90 degrees, apply operation on two broken down and smaller arcs
;; 3) check if line intersects with bounding box of circle
;; 4) check if line intersects with circle
;; 5) check if intersected points fall on the right side of the arc
;; these 3 functions calculate the x and y coordinates for arc points
(define (arc-point-x circle-x degree radius)
(let ((adjusted (localize-degree degree)))
(cond ((or (= degree 90) (= degree 270)) circle-x)
((= degree 180) (- circle-x radius))
((or (= degree 360) (= degree 0)) (+ circle-x radius))
((in-between? degree 0 90) (+ circle-x (* radius (cos (degrees->radians adjusted)))))
((in-between? degree 90 180) (- circle-x (* radius (sin (degrees->radians adjusted)))))
((in-between? degree 180 270) (- circle-x (* radius (cos (degrees->radians adjusted)))))
((in-between? degree 270 360) (+ circle-x (* radius (sin (degrees->radians adjusted)))))
(else (display "error")))))
(define (arc-point-y circle-y degree radius)
(let ((adjusted (localize-degree degree)))
(cond ((or (= degree 0) (= degree 360) (= degree 180)) circle-y)
((= degree 90) (+ circle-y radius))
((= degree 270) (- circle-y radius))
((in-between? degree 0 90) (+ circle-y (* radius (sin (degrees->radians adjusted)))))
((in-between? degree 90 180) (+ circle-y (* radius (cos (degrees->radians adjusted)))))
((in-between? degree 180 270) (- circle-y (* radius (sin (degrees->radians adjusted)))))
((in-between? degree 270 360) (- circle-y (* radius (cos (degrees->radians adjusted)))))
(else (display "error")))))
(define (localize-degree degree)
(cond ((in-between? degree 0 90) degree)
((in-between? degree 90 180) (- degree 90))
((in-between? degree 180 270) (- degree 180))
((in-between? degree 270 360) (- degree 270))))
(define (arc-intersect? arc-struct xs ys xb yb)
(let* ((radius (arc-radius arc-struct))
(circle-x (arc-x arc-struct))
(circle-y (arc-y arc-struct))
(start (arc-start arc-struct))
(end (arc-end arc-struct))
(angle-difference (if (> end start) (- end start) (+ (- 360 start) end)))
(half-angle (if (> end start) (/ (+ start end) 2) (if (< 360 (+ 180 (/ (+ start end) 2))) (- (+ 180 (/ (+ start end) 2)) 360) (+ 180 (/ (+ start end) 2)))))
(radius (arc-radius arc-struct))
(arc-x1 (arc-point-x circle-x start radius))
(arc-y1 (arc-point-y circle-y start radius))
(arc-x2 (arc-point-x circle-x end radius))
(arc-y2 (arc-point-y circle-y end radius))
;we calculate the middle arc-point to determine which is the right side
(half-x (arc-point-x circle-x half-angle radius))
(half-y (arc-point-y circle-y half-angle radius)))
;if a rectangle point is inside the circle, check whether it has intersected on the arc side of the circle
;use a line from the start of the arc to the end of the arc to create a dividing line between the right and wrong side
(define (right-side-y? x y)
(let* ((dividing-line-slope (/ (- arc-y2 arc-y1) (- arc-x2 arc-x1)))
(dividing-line-yintercept (- arc-y1 (* dividing-line-slope arc-x1)))
(right-yintercept (- half-y (* dividing-line-slope half-x)))
(right-value-test (> right-yintercept dividing-line-yintercept))
(point-yintercept (- y (* dividing-line-slope x)))
(point-test (> point-yintercept dividing-line-yintercept)))
(display (list half-x half-y half-angle))
(eq? right-value-test point-test)))
(define (line-intersect-arc? x1 y1 x2 y2)
;return the point where line intersects arc. intersection of a y line with a circle, 2 possible x values
(define (yline-intersect-circle? y)
(let ((result1 (+ circle-x (sqrt (- (expt radius 2) (expt (- y circle-y) 2)))))
(result2 (- circle-x (sqrt (- (expt radius 2) (expt (- y circle-y) 2))))))
(if (real? result1)
(cond ((and (in-between? result1 xs xb) (in-between? result2 xs xb))
(list (list result1 y) (list result2 y)))
((in-between? result1 xs xb)
(list (list result1 y)))
((in-between? result2 xs xb)
(list (list result2 y)))
(else #f))
#f)))
;return the point where line intersects arc. intersection of a x line with a circle, 2 possible y values
(define (xline-intersect-circle? x)
(let ((result1 (+ circle-y (sqrt (- (expt radius 2) (expt (- x circle-x) 2)))))
(result2 (- circle-y (sqrt (- (expt radius 2) (expt (- x circle-x) 2))))))
(if (real? result1)
(cond ((and (in-between? result1 ys yb) (in-between? result2 ys yb))
(list (list x result1) (list x result2)))
((in-between? result1 ys yb)
(list (list x result1)))
((in-between? result2 ys yb)
(list (list x result2)))
(else #f))
#f)))
(if (= x1 x2)
((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
((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
(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)
((or (line-intersect-arc? xs ys xs yb)
(line-intersect-arc? xs yb xb yb)
(line-intersect-arc? xb yb xb ys)
(line-intersect-arc? xb ys xs ys)) #t)
(else #f))))
;; divide the complete 2d space into 9 boxes
;; algorithm to detect line-rectangle intersection. separate 2d area into 9 rectangles where 0 represents the selected area
;; region numbers are bit->decimal
;; 9 1 5 1001 0001 0101
;; 8 0 4 ---> 1000 0000 0100
;; 10 2 6 1010 0010 0110
(define (cohen-sutherland line-struct xs ys xb yb)
(let ((lx1 (line-x1 line-struct))
(ly1 (line-y1 line-struct))
(lx2 (line-x2 line-struct))
(ly2 (line-y2 line-struct)))
(define (compute-outcode x y)
(let ((inside 0))
(cond ((< x xs)
(set! inside (bitwise-ior inside 1)))
((> x xb)
(set! inside (bitwise-ior inside 2))))
(cond ((< y ys)
(set! inside (bitwise-ior inside 4)))
((> y yb)
(set! inside (bitwise-ior inside 8))))
inside))
;return #t if intersect
(define (trivial-accept? region1 region2)
(or (not (bitwise-ior region1 region2))
(= region1 0)
(= region2 0)
(and (= region1 1) (= region2 2))
(and (= region1 2) (= region2 1))
(and (= region1 4) (= region2 8))
(and (= region1 8) (= region2 4))))
;return #t if does not intersect
(define (trivial-reject? region1 region2)
(not (= (bitwise-and region1 region2) 0)))
;clip until no more ambiguous cases
(define (clip-until region1 region2 tries)
(cond ((= tries 0) #f)
((trivial-reject? region1 region2) #f)
((trivial-accept? region1 region2) #t)
(else (apply clip-until (append (do-clip region1 region2) (list (- tries 1)))))))
(define (do-clip region1 region2)
(define (not0 num)
(if (= num 0) #f #t))
(let* ((new-x 0)
(new-y 0)
(slope (/ (- ly2 ly1) (- lx2 lx1)))
(y-intercept (- ly2 (* slope lx2))))
;apply the formula y = y1 + slope * (x - x1), x = x1 + (y - y1) / slope
(cond ((not0 (bitwise-and 8 region2))
(set! new-x (/ (- yb y-intercept) slope))
(set! new-y yb))
((not0 (bitwise-and 4 region2))
(set! new-x (/ (- ys y-intercept) slope))
(set! new-y ys))
((not0 (bitwise-and 2 region2))
(set! new-x xb)
(set! new-y (+ (* slope xb) y-intercept)))
((not0 (bitwise-and 1 region2))
(set! new-x xs)
(set! new-y (+ (* slope xs) y-intercept))))
(set! lx2 new-x)
(set! ly2 new-y)
(set! region2 (compute-outcode lx2 ly2)))
(list region1 region2))
(let* ((region1 (compute-outcode lx1 ly1))
(region2 (compute-outcode lx2 ly2)))
(clip-until region1 region2 4))))
;; creation functons
(define (layer->string x)
(if (string? x) x (number->string x)))
(define (create-arc2 layer x1 y1 bulge)
(+ 1 2))
(define (create-line layer x1 y1 x2 y2)
(line (layer->string layer) x1 y1 x2 y2))
(define (create-point layer x y)
(point (layer->string layer) x y))
(define (create-arc layer x y radius start end)
(arc (layer->string layer) x y radius start end))
(define (create-circle layer x y radius) ; creating 2 semicircles with create-arc
(create-arc (layer->string layer) x y radius 0 360))
;; drawing functions
(define (draw-point x y selected)
(if selected
(send drawer set-pen red-pen)
(send drawer set-pen normal-pen))
(send drawer draw-point x y))
(define (draw-line x1 y1 x2 y2 selected)
(if selected
(send drawer set-pen red-pen)
(send drawer set-pen normal-pen))
(send drawer draw-line x1 y1 x2 y2))
;; racket's draw-arc function's x,y starts at bottom left corner (docs say top left but inverted because of -ve y-scale)
;; DXF provided arc x,y coordinates are at the center of the arc/circle
(define (draw-arc x y radius start end selected)
(if selected
(send drawer set-pen red-pen)
(send drawer set-pen normal-pen))
(let ((convert-angle1 (degrees->radians (- 360 start))) ;; DXF angles are CW, Racket angles are CCW (because of inverting y scale)
(convert-angle2 (degrees->radians (- 360 end)))
(start-x (- x radius))
(start-y (- y radius)))
(send drawer draw-arc start-x start-y (* 2 radius) (* 2 radius) convert-angle2 convert-angle1)))
(define (draw-objects lst) ;get a struct-list.
(define (apply-procedure x)
(when (entity-visible x)
(match x
[(line layer selected visible x1 y1 x2 y2) (draw-line x1 y1 x2 y2 selected)]
[(arc layer selected visible x y radius start end) (draw-arc x y radius start end selected)]
[(point layer selected visible x y) (draw-point x y selected)])))
(map apply-procedure lst))
;; gui control/frame definitions
(define top-frame (new frame%
[label "KR"]
[width editor-frame-width]
[height editor-frame-height]
[alignment (list 'left 'top)]))
(define menu-bar (new menu-bar%
(parent top-frame)))
(define file (new menu%
(label "&File")
(parent menu-bar)))
(new menu-item%
(label "&Open.. ")
(parent file)
(callback (lambda (b e)
(open-file (send open run)))))
(define open (new path-dialog%
[existing? #t]
[filters (list (list "DXF Files" "*.dxf") (list "Text Files" "*.txt"))]))
;; scale the x and y values.
(define (scalex-to-display x)
(/ (- x globalx-offset) x-scale))
(define (scaley-to-display y)
(/ (- y globaly-offset) y-scale))
(define (x-scale&offset x)
(* dimension-scale (- x globalx-offset)))
(define (y-scale&offset y)
(* dimension-scale (- y globaly-offset)))
(define my-canvas%
(class canvas%
(override on-char)
(define on-char (lambda (event)
(let ((key (send event get-key-code)))
(special-control-key #t)
(case key
['wheel-up (set! x-scale (+ x-scale 0.5)) (set! y-scale (- y-scale 0.5))
(send drawer set-transformation (vector transformation-matrix globalx-offset globaly-offset x-scale y-scale rotation))]
['escape (map (lambda (x) (set-entity-selected! x #f)) struct-list)]
['wheel-down (set! x-scale (- x-scale 0.5)) (set! y-scale (+ y-scale 0.5))
(send drawer set-transformation (vector transformation-matrix globalx-offset globaly-offset x-scale y-scale rotation))]
['#\backspace (map (lambda (x) (when (entity-selected x) (set-entity-visible! x #f))) struct-list)]))
(send canvas refresh)))
(define/override (on-event event)
(define x (send event get-x))
(define y (send event get-y))
(define scaled-x (scalex-to-display (send event get-x)))
(define scaled-y (scaley-to-display (send event get-y)))
(cond
((and (send event button-down? 'left) (send event get-caps-down))
(set! init-x scaled-x)
(set! init-y scaled-y)
(set! display-select-box #t))
((and (send event button-up? 'left) (send event get-caps-down))
(set! display-select-box #f)
(intersect? init-x init-y scaled-x scaled-y struct-list)
(send canvas refresh))
((and (send event dragging?) (send event get-caps-down))
(set! select-box (list (list init-x init-y scaled-x init-y #t)
(list scaled-x init-y scaled-x scaled-y #t)
(list scaled-x scaled-y init-x scaled-y #t)
(list init-x scaled-y init-x init-y #t)))
(send canvas refresh))
((send event button-down? 'left)
(set! init-x x)
(set! init-y y))
((send event button-up? 'left)
(set! globalx-offset (vector-ref (send drawer get-transformation) 1))
(set! globaly-offset (vector-ref (send drawer get-transformation) 2)))
((send event dragging?)
(let* ((current-x (- x init-x))
(current-y (- y init-y)))
(send drawer set-transformation (vector transformation-matrix (+ current-x globalx-offset) (+ current-y globaly-offset) x-scale y-scale rotation))
(send canvas refresh)))))
(super-instantiate ())))
(define canvas (new my-canvas%
[parent top-frame]
;[style (list 'hscroll 'vscroll 'resize-corner)]
[paint-callback (lambda (canvas dc)
(send drawer set-brush no-brush)
(when display-select-box (draw-select-box select-box))
(draw-objects struct-list)
(send drawer set-pen normal-pen)
)]))
(define (draw-select-box lst)
(for/list ([i lst])
(apply draw-line i)))
(define (update-layer-list struct-list)
(set! list-of-layers (map (lambda (x) (if (string? x) x (number->string x)))
(remove-duplicates (map entity-layer struct-list))))) ;layers as numbers changed to string
(define (display-layers)
(set! current-display '()) ;this must be here. when opening a file with a layer name that exists in the currently opened file that is checked,
;it will be impossible to enable/disable that layer in the new file.
(map (lambda (x) (when (is-a? x check-box%) (send top-frame delete-child x)))
(send top-frame get-children)) ;delete all existing check-boxes
(for/list ([i list-of-layers])
(new check-box%
(label i)
(parent top-frame)
(callback (lambda (checked e)
(if (send checked get-value)
(map (lambda (k) (when (equal? (entity-layer k) i) (set-entity-visible! k #t) (set-entity-selected! k #f))) struct-list)
(map (lambda (k) (when (equal? (entity-layer k) i) (set-entity-visible! k #f))) struct-list))
(draw-objects struct-list)
(send canvas on-paint)
(send canvas refresh-now))))))
;; gui definitions
(define no-brush (new brush% [style 'transparent]))
(define red-pen (new pen% [color "red"] [width 2]))
(define normal-pen (new pen% [color "black"] [width 1]))
(define drawer (send canvas get-dc))
;; test definitions
(set! struct-list (list (create-line "x" -50 50 50 50)
(create-line "x" 50 50 50 -50)
(create-line "x" 50 -50 -50 -50)
(create-line "x" -50 -50 -50 50)
(create-arc "x" 100 100 50 30 330)
;(create-arc "x" 294.31 126 59.9 180 90) ;point is 315
;(create-arc "x" 294.31 126 30.6 180 90)
(create-arc "x" 0 0 50 327.4631824838592 32.53681751614075)))
;(create-arc "x" 0 0 50 330 180)))
;(create-arc "x" 153.9669450660056 285.3098684701261 84.71074975327349 327.4631824838592 32.53681751614075)
;(294.3174411004558 126.0053584092479 43.86927579696467 0.0 59.94324081039581)
;(294.3174411004558 126.0053584092479 43.8692757969647 0.0 30.63039395055559)
(foldl set-entity-visible! #t struct-list)
(send top-frame show #t)
(send drawer set-transformation (vector transformation-matrix globalx-offset globaly-offset x-scale y-scale rotation))
(sleep/yield 0.1)
