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 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)))
           (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))
           (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"))))]))

;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)
;  (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)))

(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))
      ;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))
      (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))))
    ;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)))
        ((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)
  • 1
    \$\begingroup\$ It is unclear what you need help with. Please include some context to your post, other than your code, that states what improvements you are looking for. \$\endgroup\$ – SirPython Jan 18 '15 at 19:04
  • 2
    \$\begingroup\$ Hi. Welcome to Code Review! It would also help if you would provide a problem statement explaining what this code is supposed to do. \$\endgroup\$ – Brythan Jan 18 '15 at 19:44
  • \$\begingroup\$ Hello, i've changed the problem statement, although i thought Code Review was a place where you could post working code that you think can be improved on? \$\endgroup\$ – KRC Jan 20 '15 at 7:48
  • \$\begingroup\$ By problem statement, I mean to state the problem that the code solves. What is this code supposed to do? \$\endgroup\$ – Brythan Jan 20 '15 at 8:04
  • \$\begingroup\$ @Brythan Doesn't the title explain what the purpose of the code is? \$\endgroup\$ – 200_success Jan 20 '15 at 8:08

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.