dxf-canvas.rkt

#lang racket/gui

#|
This module is where i store the custom canvas class for displaying DXF elements : ARC, LINE, DOT, CIRCLE, LWPOLYLINE.
Functions here include:
custom popup menus
custom event handling behavior with respect to mouse and key events (see on-event and on-char respectively
helper functions (scaling, sorting connected entities into a single path, intersection query functions, updating entity list that is displayed from an outside spreadsheet)
drawing functions
TODO:
add ctrl-a for select all function
add undo function
limit panning and zooming with respect to a specified workspace limit
|#

(require "structs.rkt"
         "canvas-utils.rkt"
         "lst-utils.rkt"
         "untyped-utils.rkt"
         "utils.rkt"
         "graph.rkt"
         racket/draw)

(provide dxf-canvas%)

(define dxf-canvas%
  (class canvas%
    
    ;shorten
    (inherit get-dc refresh refresh-now get-width get-height suspend-flush resume-flush)
    
    (init-field
     ;;vars
     search-list
     original-list
     x-offset
     y-offset
     
     ;;fns
     ;coordinate scaling
     upscale-x
     downscale-x
     upscale-y
     downscale-y
     
     ;;how much variation before we can consider nodes to be connected
     tolerance
     
     update-spreadsheet!)
    
    (field 
     ;canvas display variables
     [rotation 0]
     [transformation-matrix (vector 1 0 0 1 0 0)]
     
     ;interaction variables
     [init-cursor-x 0]
     [init-cursor-y 0]
     [cursor-x 0]
     [cursor-y 0]
     [scaled-cursor-x 0]
     [scaled-cursor-y 0]
     [x-scale 1]
     [y-scale 1]
     
     ;display selection box
     [select-box '()]
     
     [node-groups '()] ;contains list of list of nodes. see group-entities to understand
     [highlighted-node #f] ;clickpoint near cursor
     [path-lst '()]  ;list of connections
     [node-lst '()] ;list of clickable nodes
     [prev-highlight '()])
    
    ;; DRAWING COLORS
    (define no-brush (new brush% [style 'transparent]))
    (define blue-pen (new pen% [color "RoyalBlue"] [width 1]))
    (define black-pen (new pen% [color "black"] [width 1]))
    (define orange-pen (new pen% [color "Orange"] [width 1]))
    (define big-black-pen (new pen% [color "black"] [width 5]))
    (define big-blue-pen (new pen% [color "RoyalBlue"] [width 5]))
    (define big-orange-pen (new pen% [color "Orange"] [width 5]))
    
    ;; CURSOR TYPES
    (define normal (make-object cursor% 'arrow))
    (define panning (make-object cursor% 'hand))
    (define selecting (make-object cursor% 'cross))
    
    ;; MORE SCALING FUNCTIONS
    ;; any function that uses node-equal should accept this as an argument
    ;; (-> node node)
    (define node-val
      (lambda (n)
        (node (downscale-x (node-x n))
              (downscale-y (node-y n)))))
    
    (define (unhighlight-entities! lst)
      (unless (empty? lst)
        (for/list ([j lst])
                  (when (path? j) (map (lambda (x) (set-entity-highlighted! x #f)) (path-entities j)))
                  (set-entity-highlighted! j #f))))
    
    ;; MOUSE SCALING
    ;scale mouse coordinates to pixel coordinates
    (define (mouse2display-x x)
      (/ (- x x-offset) x-scale))
    (define (mouse2display-y y)
      (/ (- y y-offset) y-scale))
    
    (define (change-pen! pen-type)
      (send (get-dc) set-pen pen-type))
    
    (define (change-cursor! cursor-type)
      (send this set-cursor cursor-type))
    
    ;; DRAWING FUNCTIONS
    (define (draw-dot! x y)
      (define original-pen (send (get-dc) get-pen))
      (cond [(equal? original-pen blue-pen) (change-pen! big-blue-pen)]
            [(equal? original-pen black-pen) (change-pen! big-black-pen)]
            [(equal? original-pen orange-pen) (change-pen! big-orange-pen)])
      (send (get-dc) draw-point x y)
      (send (get-dc) set-pen original-pen))
    
    (define (draw-line! x1 y1 x2 y2 dc-path)
      (send dc-path move-to x1 y1)
      (send dc-path line-to x2 y2)
      (send dc-path close))
    
    (define (draw-start/end-nodes x y)
      (send (get-dc) draw-point x y))
    
    ;p1 p2 p3 and ccw are for debugging. they're so useful so leave them in for now.
    (define (draw-arc! x y radius start end p1 p2 p3 ccw dc)
      ;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
      (let ((start (degrees->radians (- 360 start))) ;; DXF angles are CW, Racket angles are CCW (because of inverting y scale)
            (end (degrees->radians (- 360 end)))
            (center-x (- x radius))
            (center-y (- y radius))
            [x1 (node-x p1)]
            [y1 (node-y p1)]
            [x2 (node-x p2)]
            [y2 (node-y p2)]
            [x3 (node-x p3)]
            [y3 (node-y p3)])
        ;(draw-line! x1 y1 x2 y2 highlight?)
        ;(draw-line! x2 y2 x3 y3 highlight?)
        (if ccw
            (send (get-dc) draw-arc center-x center-y (* 2 radius) (* 2 radius) start end)
            (send (get-dc) draw-arc center-x center-y (* 2 radius) (* 2 radius) end start))))
    
    ;make public to allow checking/unchecking of layers outside of the canvas
    (define/public (draw-objects! lst)
      (let ([dc (get-dc)])
        (define (apply-procedure x dc-path)
          (when (entity-visible x)
            (match x
              [(line _ _ _ _ p1 p2 _)                                 ;(draw-line! 0 0 (node-x p1) (node-y p1) dc-path)
               (draw-line! (node-x p1) (node-y p1) (node-x p2) (node-y p2) dc-path)]
              [(arc _ _ _ _ center radius start end p1 p2 p3 ccw _)   ;(draw-line! 0 0 (node-x p1) (node-y p1) dc-path)
               (draw-arc! (node-x center) (node-y center) radius start end p1 p2 p3 ccw dc)]
              [(dot _ _ _ _ p)                                        ;(draw-line! 0 0 (node-x p) (node-y p) dc-path)
               (draw-dot! (node-x p) (node-y p))]
              [(path _ _ _ _ path-list)
               (map (lambda (x) (apply-procedure x dc-path)) path-list)])))
        (let* ([path1 (new dc-path%)]
               [path2 (new dc-path%)]
               [path3 (new dc-path%)]
               [x1 (- scaled-cursor-x 3)]
               [y1 (- scaled-cursor-y 3)]
               [x2 (+ scaled-cursor-x 3)]
               [y2 (+ scaled-cursor-y 3)]
               [big-x (biggest (list x1 x2))]
               [big-y (biggest (list y1 y2))]
               [small-x (smallest (list x1 x2))]
               [small-y (smallest (list y1 y2))]
               [selected-entities (get-selected-entities search-list)])
          
          (change-pen! big-blue-pen)
          (for/list ([i node-lst])
                    (draw-start/end-nodes (node-x i) (node-y i)))
          (unless (empty? prev-highlight)
            (unhighlight-entities! prev-highlight)
            (set! prev-highlight '()))
          (change-pen! big-orange-pen)
          (for/list ([i node-lst])
                    (when (point-in-rect? (node-x i) (node-y i) small-x small-y big-x big-y)
                      (let* ([selected-list (get-belonging-list i node-groups)]
                             [highlighted-node-lst (get-start/end-nodes selected-list)])
                        (set! highlighted-node i)
                        (set! prev-highlight selected-list)
                        (for/list ([i selected-list])
                                  (when (path? i) (map (lambda (x) (set-entity-highlighted! x #t)) (path-entities i)))
                                  (set-entity-highlighted! i #t))
                        (for/list ([i highlighted-node-lst])
                                  (draw-start/end-nodes (node-x i) (node-y i))))))
          
          ;; 
          ;; BECAUSE ARCS CAN'T BE INCLUDED IN THE DC PATH, WE DRW THEM SEPARATELY FROM LINES/DOTS
          ;; OTHERWISE WE HAVE TO CALL change-pen! A LOT.
          (change-pen! black-pen)
          (for/list ([x (filter (lambda (x) (and (not (entity-highlighted x)) (not (entity-selected x)))) lst)])
                    (apply-procedure x path1))
          (send (get-dc) draw-path path1)
          
          (change-pen! blue-pen)
          (for/list ([x (filter (lambda (x) (or (entity-highlighted x) (entity-selected x))) lst)])
                    (apply-procedure x path2))
          (send (get-dc) draw-path path2)
          (draw-select-box! select-box path2)
          
          (change-pen! orange-pen)
          (for/list ([x (filter (lambda (x) (and (entity-highlighted x) (entity-selected x))) lst)])
                    (apply-procedure x path3))
          (send (get-dc) draw-path path3)
          
          )))
    
    (define (draw-select-box! lst dc-path)
      (unless (empty? select-box)
        (let* ([big-x (biggest (take lst 2))]
               [big-y (biggest (drop lst 2))]
               [small-x (smallest (take lst 2))]
               [small-y (smallest (drop lst 2))]
               [width (difference big-x small-x)]
               [height (difference big-y small-y)])
          (begin (send dc-path rectangle small-x small-y width height)
                 (send (get-dc) draw-path dc-path)))))
    
    ;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 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))]
             [query-mbr (rect small-x small-y big-x big-y)]
             )
        (for/list ([i (filter (lambda (x) (and (entity-visible x) (not (entity-selected x)))) lst)])
          ;only calculate intersections for visible and not yet selected items
          (cond [(line? i)
                 (if (and (rect-intersect? (line-mbr i) query-mbr)
                          (line-intersect? i small-x small-y big-x big-y))
                     (set-entity-highlighted! i #t)
                     (set-entity-highlighted! i #f))]
                [(arc? i)
                 (if ;(and (rect-intersect? (arc-mbr i) query-mbr)
                  (arc-intersect? i small-x small-y big-x big-y)
                  ;)
                  (set-entity-highlighted! i #t)
                  (set-entity-highlighted! i #f))]
                [(dot? i)
                 (if (point-in-rect? (node-x (dot-p i)) (node-y (dot-p i)) small-x small-y big-x big-y)
                     (set-entity-highlighted! i #t)
                     (set-entity-highlighted! i #f))]
                [(path? i)
                 (intersect? x1 y1 x2 y2 (path-entities i))]))))
    
    ;don't include paths
    (define/public (update-node-lst!)
      (let ([to-display-for (get-selected-entities (filter-not dot? search-list))])
        (if (empty? to-display-for)
            (set! node-lst '())
            (begin
              (unless (empty? to-display-for)
                (set! node-groups (group-entities (get-selected-entities search-list))))
              (let ([islands-removed (filter-not (lambda (group) (= 1 (length group))) node-groups)]) ;i.e. a path, dont need to show nodes for it
                (set! node-lst (remove-duplicates (flatten (map get-start/end-nodes islands-removed)))))))))
    
    (define/public (update-canvas!)
      (send (get-dc) set-transformation (vector transformation-matrix x-offset y-offset x-scale y-scale rotation))
      (refresh))
    
    (define/public (refocus!)
      (define-values (w h) (send this get-client-size))
      (when (get-visible-entities search-list)
        (let* ([entity-lst (get-visible-entities search-list)]
               [canvas-width w]
               [canvas-height h]
               [bottom (biggest (get-y-vals entity-lst))]
               [top (smallest (get-y-vals entity-lst))]
               [left (smallest (get-x-vals entity-lst))]
               [right (biggest (get-x-vals entity-lst))]
               [height (if (zero? (difference top bottom))
                           100
                           (difference top bottom))]
               [width (if (zero? (difference right left))
                           100
                           (difference right left))]
               [scale-x (/ canvas-width width)]
               [scale-y (/ canvas-height height)]
               ;0.864 -> 0.8, 1.113 -> 1.1
               [floor-0.1 (lambda (x)
                            (let* ([multiples (floor (/ x 0.1))]
                                   [remainder (/ multiples 10)])
                              (if (= remainder 0) 0.1 remainder)))]
               [drawing-scale (floor-0.1 (smallest (list scale-x scale-y)))]
               [mid-x (/ (+ left right) 2)]
               [mid-y (/ (+ top bottom) 2)]
               ;;change from canvas/pixel coordinates to real coordinates
               [corner-x (- mid-x (/ (/ canvas-width 2) drawing-scale))]
               [corner-y (- mid-y (/ (/ canvas-height 2) drawing-scale))]
               [x-off (* -1 corner-x drawing-scale)]
               [y-off (* -1 corner-y drawing-scale)])
          (for ([i (list right left (get-x-vals entity-lst) entity-lst)])
            (println i))
          (set! x-offset x-off)
          (set! y-offset y-off)
          (set! x-scale drawing-scale)
          (set! y-scale drawing-scale)
          ))
      (update-canvas!))
    
    ;; POPUP MENU
    (define popup-opened
      (new popup-menu%
           [popdown-callback (lambda (p e)
                               (when (equal? (send e get-event-type) 'menu-popdown-none) 
                                 (unhighlight-entities! prev-highlight)
                                 (set! highlighted-node #f)))]))
    
    (define popup-error
      (new popup-menu%
           [popdown-callback (lambda (p e)
                               (when (equal? (send e get-event-type) 'menu-popdown-none) 
                                 (unhighlight-entities! prev-highlight)
                                 (set! highlighted-node #f)))]))
    
    (define popup-closed
      (new popup-menu%
           [popdown-callback (lambda (p e)
                               (when (equal? (send e get-event-type) 'menu-popdown-none) 
                                 (unhighlight-entities! prev-highlight)
                                 (set! highlighted-node #f)))]))
    
    ;; POPUP MENU items
    (define display-err
      (new menu-item%
           [label "Form paths from a tree pattern."]
           [parent popup-error]
           [callback (lambda (b e)
                       (let* ([to-remove (get-belonging-list highlighted-node node-groups)]
                              [base-elements (get-base-elements to-remove)]
                              [to-add (foldl (lambda (next acc)
                                                  (cons 
                                                   (if (> (length next) 1)
                                                       (make-selected! (make-path next))
                                                       (make-selected! (car next)))
                                                   acc))
                                                '() (reorder-tree-path highlighted-node base-elements))])
                         (set! search-list (append to-add (remove* base-elements search-list)))
                         (update-node-lst!)
                         (update-canvas!)
                         (update-spreadsheet! search-list))
                       )]))
    
    (define open-nodir
      (new menu-item%
           [label "Form an open path."]
           [parent popup-opened]
           [callback (lambda (b e)
                       (let* ([list-of-entities-to-reorder (get-belonging-list highlighted-node node-groups)]
                              [base-elements (get-base-elements list-of-entities-to-reorder)]
                              [new-path (make-selected! (make-path (reorder-open-path highlighted-node base-elements)))])
                         (set! search-list (append (list new-path) (remove* list-of-entities-to-reorder search-list)))
                         (update-node-lst!)
                         (update-canvas!)
                         (update-spreadsheet! search-list))
                       )]))
    
    (define closed-clockwise
      (new menu-item%
           [label "Form a path that moves clockwise from this point."]
           [parent popup-closed]
           [callback (lambda (b e)
                       (let* ([list-of-entities-to-reorder (get-belonging-list highlighted-node node-groups)]
                              [base-elements (get-base-elements list-of-entities-to-reorder)]
                              [new-path (make-selected! (make-path (reorder-closed-path highlighted-node base-elements #f)))])
                         (set! search-list (append (list new-path) (remove* list-of-entities-to-reorder search-list)))
                         (update-node-lst!)
                         (update-canvas!)
                         (update-spreadsheet! search-list)))]))
    
    (define closed-anticlockwise
      (new menu-item%
           [label "Form a path that moves anti-clockwise from this point."]
           [parent popup-closed]
           [callback (lambda (b e)
                       (let* ([list-of-entities-to-reorder (get-belonging-list highlighted-node node-groups)]
                              [base-elements (get-base-elements list-of-entities-to-reorder)]
                              [new-path (make-selected! (make-path (reorder-closed-path highlighted-node base-elements #t)))])
                         (set! search-list (append (list new-path) (remove* list-of-entities-to-reorder search-list)))
                         (update-node-lst!)
                         (update-canvas!)
                         (update-spreadsheet! search-list)))]))
    
    ;; KEYBOARD events
    (define/override (on-char event)
      (let ((key (send event get-key-code)))
        (special-control-key #t)
        (cond [(equal? key 'wheel-up)
               (set! x-scale (+ x-scale 0.1)) 
               (set! y-scale (+ y-scale 0.1))]
              [(equal? key 'escape) 
               (set! node-groups '()) 
               (unselect-all! search-list)
               (update-node-lst!)
               (update-spreadsheet! search-list)]
              [(equal? key 'wheel-down) 
               (when (> (- x-scale 0.1) 0) 
                 (set! x-scale (- x-scale 0.1))
                 (set! y-scale (- y-scale 0.1)))]
              [(equal? key '#\backspace)
               (set! node-groups '()) 
               (delete-selected! search-list)
               (update-node-lst!)
               (update-spreadsheet! search-list)])
        (update-canvas!)))
    
    ;; MOUSE events
    (define/override (on-event event)
      
      (define drawer (get-dc))
      
      (set! cursor-x (send event get-x))
      (set! cursor-y (send event get-y))
      (set! scaled-cursor-x (mouse2display-x cursor-x))
      (set! scaled-cursor-y (mouse2display-y cursor-y))
      
      (define-syntax-rule (is-key-event? query)
        (send event query))
      (define (is-mouse-event? query)
        (equal? query (send event get-event-type)))
      
      ;key and mouse combinations
      (define click-right (is-mouse-event? 'right-down))
      (define click-left (is-mouse-event? 'left-down))
      (define release-left (is-mouse-event? 'left-up))
      (define hold-ctrl (is-key-event? get-control-down))
      (define caps-on (is-key-event? get-caps-down))
      (define dragging (send event dragging?)) ;click and hold
      
      (define start-panning? click-left)
      (define is-panning? (and dragging (number? init-cursor-x) (number? init-cursor-y)))
      (define end-panning? release-left)
      (define start-selecting? #f)
      (define is-selecting? #f)
      (cond [(equal? (system-type 'os) 'macosx)
             (set! start-selecting? (and click-left caps-on))
             (set! is-selecting? (and dragging caps-on))]
            [else
             (set! start-selecting? (and click-left hold-ctrl))
             (set! is-selecting? (and dragging hold-ctrl))])
      ;use select-box as a flag to check whether we were selecting previously.
      (define end-selecting? (and release-left (not (empty? select-box))))
      (define show-popup? (and (node? highlighted-node) click-right))
      (define click-detected? (and release-left
                                   (> 0.5 (difference scaled-cursor-x init-cursor-x))
                                   (> 0.5 (difference scaled-cursor-y init-cursor-y))))
      
      (refresh)
      
      (cond
        (end-selecting?
         (change-cursor! normal)
         (select-highlighted! search-list)
         (update-spreadsheet! search-list)
         (set! select-box '())
         (update-node-lst!)
         (update-canvas!))
        (end-panning?
         ;see conditions for is-panning? to understand setting init-cursor-x and init-cursor-y values
         (set! init-cursor-x #f)
         (set! init-cursor-y #f)
         ;fix the offset so that the screen stays where it is after panning is finished
         (set! x-offset (vector-ref (send drawer get-transformation) 1)) 
         (set! y-offset (vector-ref (send drawer get-transformation) 2))
         (change-cursor! normal))
        (start-selecting?
         (change-cursor! selecting)
         (set! init-cursor-x scaled-cursor-x)
         (set! init-cursor-y scaled-cursor-y)
         (set! select-box (list init-cursor-x scaled-cursor-x init-cursor-y scaled-cursor-y)))
        (start-panning?
         (set! init-cursor-x cursor-x)
         (set! init-cursor-y cursor-y)
         (unhighlight-entities! prev-highlight)
         (set! highlighted-node #f))
        (show-popup?
         (let* ([selected-list (get-base-elements (get-belonging-list highlighted-node node-groups))]
                [node-lst (entities->nodes selected-list)]
                [closed-pattern? (and (not (more-than-2? node-lst)) (closed-path? node-lst))]
                [open-pattern? (and (not (more-than-2? node-lst)) (open-path? node-lst))]
                [tree-pattern? (more-than-2? node-lst)])
           (cond [tree-pattern? (send this popup-menu popup-error cursor-x cursor-y)]
                 [open-pattern? (send this popup-menu popup-opened cursor-x cursor-y)]
                 [closed-pattern? (send this popup-menu popup-closed cursor-x cursor-y)])))
        (is-selecting?
         (intersect? init-cursor-x init-cursor-y scaled-cursor-x scaled-cursor-y search-list)
         (highlight-paths! search-list)
         (set! select-box (list init-cursor-x scaled-cursor-x init-cursor-y scaled-cursor-y)))
        (is-panning?
         (let* ((current-x (- cursor-x init-cursor-x))
                (current-y (- cursor-y init-cursor-y)))
           (change-cursor! panning)
           (send drawer set-transformation (vector transformation-matrix (+ current-x x-offset) (+ current-y y-offset) x-scale y-scale rotation))
           (refresh)))))
    
    (define/override (on-paint)
      (define drawer (get-dc))
      (send this suspend-flush)
      (send drawer set-brush no-brush)
      (draw-objects! search-list)
      (define-values (w h) (send this get-client-size))
      #|
      (when (not (empty? (get-visible-entities search-list)))
        (let* ([canvas-width w]
               [canvas-height h]
               [entity-lst (get-visible-entities search-list)]
               [left (smallest (get-x-vals entity-lst))]
               [right (biggest (get-x-vals entity-lst))]
               [bottom (biggest (get-y-vals entity-lst))]
               [top (smallest (get-y-vals entity-lst))]
               [canvas-center-x (/ (get-width) 2)]
               [canvas-center-y (/ (get-height) 2)]
               [mid-x (/ (+ left right) 2)]
               [mid-y (/ (+ top bottom) 2)]
               [left-x (- mid-x (/ (/ canvas-width 2) x-scale))]
               [right-x (+ mid-x (/ (/ canvas-width 2) x-scale))])
          (send (get-dc) draw-line! mid-x mid-y right-x mid-y)
          (send (get-dc) draw-line! mid-x mid-y left-x mid-y)
          (send (get-dc) draw-line! left bottom left top)
          (send (get-dc) draw-line! left top right top)
          (send (get-dc) draw-line! right top right bottom)
          (send (get-dc) draw-line! right bottom left bottom)))
      |#
      (send this resume-flush))
    
    (super-instantiate ())))