PasteRack.org
Paste # 29128
2015-05-23 05:55:32

Fork as a new paste.

Paste viewed 298 times.


Embed:

  1. #lang racket
  2.  
  3. (require "structs.rkt"
  4.          "read_dxf.rkt"
  5.          "geometric_functions.rkt"
  6.          "ils-pattern-generator.rkt"
  7.          "ids-pattern-generator.rkt"
  8.          "constants.rkt"
  9.          racket/gui/base pict
  10.          racket/draw
  11.          mrlib/path-dialog
  12.          racket/math
  13.          math/matrix
  14.          framework)
  15.  
  16. (define my-canvas%
  17.   (class canvas%
  18.     ;shorten
  19.     (inherit get-dc)
  20.     (define dc (get-dc))
  21.  
  22.     (init-field search-list
  23.                 x-offset
  24.                 y-offset
  25.                 drawing-scale
  26.                 [x-scale 1]
  27.                 [y-scale -1]
  28.                 [display-select-box #f]
  29.                 [select-box '()])
  30.  
  31.     (field [set-park-position #f]
  32.            [rotation 0]
  33.            [init-x 0]
  34.            [init-y 0]
  35.            [left 0]
  36.            [bottom 0]
  37.            [transformation-matrix (vector 1 0 0 1 0 0)])
  38.  
  39.     (define no-brush (new brush% [style 'transparent]))
  40.     (define red-pen (new pen% [color "red"] [width 2]))
  41.     (define normal-pen (new pen% [color "black"] [width 1]))
  42.  
  43.     ;; DRAWING functions
  44.     (define (draw-point x y selected highlighted)
  45.       (if (or selected highlighted)
  46.           (send dc set-pen red-pen)
  47.           (send dc set-pen normal-pen))
  48.       (send dc draw-point x y))
  49.  
  50.     (define (draw-line x1 y1 x2 y2 selected highlighted)
  51.       (if (or selected highlighted)
  52.           (send dc set-pen red-pen)
  53.           (send dc set-pen normal-pen))
  54.       (send dc draw-line x1 y1 x2 y2))
  55.  
  56.     ;racket's draw-arc function's x,y starts at bottom left corner (docs say top left but inverted because of -ve y-scale)
  57.     ;DXF provided arc x,y coordinates are at the center of the arc/circle
  58.     (define (draw-arc x y radius start end selected highlighted)
  59.       (if (or selected highlighted)
  60.           (send dc set-pen red-pen)
  61.           (send dc set-pen normal-pen))
  62.       (let ((convert-angle1 (degrees->radians (- 360 start))) ;; DXF angles are CW, Racket angles are CCW (because of inverting y scale)
  63.             (convert-angle2 (degrees->radians (- 360 end)))
  64.             (start-x (- x radius))
  65.             (start-y (- y radius)))
  66.         (send dc draw-arc start-x start-y (* 2 radius) (* 2 radius) convert-angle2 convert-angle1)))
  67.  
  68.     (define (draw-objects lst) ;get a struct-list.
  69.       (define (apply-procedure x)
  70.         (when (entity-visible x)
  71.           (match x
  72.             [(line layer highlighted selected visible x1 y1 x2 y2)                           (draw-line x1 y1 x2 y2 selected highlighted)]
  73.             [(arc layer highlighted selected visible x y radius start end x1 y1 x2 y2 x3 y3) (draw-arc x y radius start end selected highlighted)]
  74.             [(point layer highlighted selected visible x y)                                  (draw-point x y selected highlighted)]
  75.             [(path layer highlighted selected visible path-list)                             (draw-objects path-list)])))
  76.       (map apply-procedure lst))
  77.  
  78.     (define (draw-select-box lst)
  79.       (for/list ([i lst])
  80.         (apply draw-line i)))
  81.  
  82.     ;; UTILITY functions
  83.     ;pass intersect? the start and end point of select box and the struct-list
  84.     ;it will traverse the struct-list to see if any elements
  85.     (define (intersect? x1 y1 x2 y2 struct-lst)
  86.       (let ((big-x (biggest (list x1 x2)))
  87.             (big-y (biggest (list y1 y2)))
  88.             (small-x (smallest (list x1 x2)))
  89.             (small-y (smallest (list y1 y2))))
  90.         (for/list ([i struct-lst])
  91.           ;only calculate intersections for visible and not yet selected items
  92.           (when (and (entity-visible i) (not (entity-selected i)))
  93.             (cond ((line? i)
  94.                    (if (cohen-sutherland i small-x small-y big-x big-y)
  95.                        (set-entity-highlighted! i #t)
  96.                        (set-entity-highlighted! i #f)))
  97.                   ((arc? i)
  98.                    (if (arc-intersect? i small-x small-y big-x big-y)
  99.                        (set-entity-highlighted! i #t)
  100.                        (set-entity-highlighted! i #f)))
  101.                   ((point? i)
  102.                    (if (point-in-rect? (point-x i) (point-y i) small-x small-y big-x big-y)
  103.                        (set-entity-highlighted! i #t)
  104.                        (set-entity-highlighted! i #f)))
  105.                   ((path? i)
  106.                    (intersect? x1 y1 x2 y2 (path-entities i))))))))
  107.  
  108.     (define (rescale struct-lst scale)
  109.       (flatten (for/list ([i struct-lst])
  110.                  (match i
  111.                    [(line layer highlighted selected visible x1 y1 x2 y2)                           (line layer (scale-x x1) (scale-y y1) (scale-x x2) (scale-y y2))]
  112.                    [(arc layer highlighted selected visible x y radius start end x1 y1 x2 y2 x3 y3) (arc layer (scale-x x) (scale-y y) (* scale radius) start end (scale-x x1) (scale-y y1) (scale-x x2) (scale-y y2) (scale-x x3) (scale-y y3))]
  113.                    [(point layer highlighted selected visible x y)                                  (point layer (scale-x x) (scale-y y))]
  114.                    [(path layer highlighted selected visible path-list)                             (path layer (rescale path-list scale))]))))
  115.  
  116.     (define (downscale struct-lst scale)
  117.       (flatten (for/list ([i struct-lst])
  118.                  (match i
  119.                    [(line layer highlighted selected visible x1 y1 x2 y2)                           (line layer (unscale-x x1) (unscale-y y1) (unscale-x x2) (unscale-y y2))]
  120.                    [(arc layer highlighted selected visible x y radius start end x1 y1 x2 y2 x3 y3) (arc layer (unscale-x x) (unscale-y y) (/ radius scale) start end (unscale-x x1) (unscale-y y1) (unscale-x x2) (unscale-y y2) (unscale-x x3) (unscale-y y3))]
  121.                    [(point layer highlighted selected visible x y)                                  (point layer (unscale-x x) (unscale-y y))]
  122.                    [(path layer highlighted selected visible path-list)                             (path layer (downscale path-list scale))]))))
  123.  
  124.     (define (get-relevant-list)
  125.       (filter-struct-list search-list (lambda (i) (and (entity-visible i) (entity-selected i)))))
  126.  
  127.     (define (select-highlighted)
  128.       (lambda (x)
  129.         (when (path? x)
  130.           (when (filter-struct-list (path-entities x) (select-highlighted))
  131.             (set-entity-selected! x #t)))
  132.         (when (entity-highlighted x)
  133.           (set-entity-selected! x #t)
  134.           (set-entity-highlighted! x #f))))
  135.  
  136.     (define (highlight-path)
  137.       (define (any-entity-highlighted? lst)
  138.         (cond ((empty? lst) #f)
  139.               ((entity-highlighted (car lst)) #t)
  140.               (else (any-entity-highlighted? (cdr lst)))))
  141.       (map (lambda (x) (when (any-entity-highlighted? (path-entities x))
  142.                          (foldl set-entity-highlighted! #t (path-entities x))))
  143.            (filter-struct-list search-list path?)))
  144.  
  145.     (define (unselect-all)
  146.       (lambda (x)
  147.         (when (path? x) (filter-struct-list (path-entities x) (unselect-all)))
  148.         (set-entity-selected! x #f)))
  149.  
  150.     (define (delete-selected)
  151.       (lambda (x)
  152.         (when (path? x) (filter-struct-list (path-entities x) (delete-selected)))
  153.         (when (entity-selected x) (set-entity-visible! x #f) (set-entity-selected! x #f))))
  154.  
  155.     (define (scale-x coord)
  156.       (* drawing-scale (- coord left)))
  157.  
  158.     (define (scale-y coord)
  159.       (* drawing-scale (- coord bottom)))
  160.  
  161.     (define (unscale-x coord)
  162.       (+ left (/ coord drawing-scale)))
  163.  
  164.     (define (unscale-y coord)
  165.       (+ bottom (/ coord drawing-scale)))
  166.  
  167.     ;; KEYBOARD events
  168.     (define/override (on-char event)
  169.       (let ((key (send event get-key-code)))
  170.         (special-control-key #t)
  171.         (case key
  172.           ['wheel-up    (set! x-scale (+ x-scale 0.1))
  173.                         (set! y-scale (- y-scale 0.1))
  174.                         (send this set-transformation (vector transformation-matrix x-offset y-offset x-scale y-scale rotation))]
  175.           ['escape      (filter-struct-list search-list (unselect-all))]
  176.           ['wheel-down  (when (> (- x-scale 0.1) 0)
  177.                           (set! x-scale (- x-scale 0.1))
  178.                           (set! y-scale (+ y-scale 0.1))
  179.                           (send dc set-transformation (vector transformation-matrix x-offset y-offset x-scale y-scale rotation)))]
  180.           ['#\backspace (filter-struct-list search-list (delete-selected))]))
  181.       (send this refresh))
  182.  
  183.     ;; MOUSE events
  184.     (define/override (on-event event)
  185.       (define x (send event get-x))
  186.       (define y (send event get-y))
  187.       (define-syntax-rule (is-key-event? query)
  188.         (send event query))
  189.       (define (is-mouse-event? query)
  190.         (equal? query (send event get-event-type)))
  191.  
  192.       ;scale the x and y values.
  193.       (define (scalex-to-display x)
  194.         (/ (- x x-offset) x-scale))
  195.       (define (scaley-to-display y)
  196.         (/ (- y y-offset) y-scale))
  197.       (define scaled-x (scalex-to-display (send event get-x)))
  198.       (define scaled-y (scaley-to-display (send event get-y)))
  199.  
  200.       ;key and mouse combinations
  201.       (define start-panning? (is-mouse-event? 'left-down))
  202.       (define is-panning? (send event dragging?))
  203.       (define end-panning? (is-mouse-event? 'left-up))
  204.       (define start-selecting? (and (is-mouse-event? 'left-down) (is-key-event? get-caps-down)))
  205.       (define is-selecting? (and (send event dragging?) (is-key-event? get-caps-down)))
  206.       (define end-selecting? (and (is-mouse-event? 'left-up) (is-key-event? get-caps-down)))
  207.       (define set-park-position? (and set-park-position (is-mouse-event? 'left-down)))
  208.  
  209.       (cond
  210.         (set-park-position?
  211.          (display (list (unscale-x scaled-x) (unscale-y scaled-y)))
  212.          (send dc draw-point scaled-x scaled-y)
  213.          (display (optimize-pattern (get-relevant-list) (point "origin" (unscale-x scaled-x) (unscale-y scaled-y))))
  214.          (set! set-park-position #f))
  215.         (start-selecting?
  216.          (set! init-x scaled-x)
  217.          (set! init-y scaled-y)
  218.          (set! display-select-box #t))
  219.         (end-selecting?
  220.          (send this set-cursor (make-object cursor% 'arrow))
  221.          (set! display-select-box #f)
  222.          (filter-struct-list search-list (select-highlighted))
  223.          (send this refresh))
  224.         (is-selecting?
  225.          (send this set-cursor (make-object cursor% 'cross))
  226.          (intersect? init-x init-y scaled-x scaled-y search-list)
  227.          (highlight-path)
  228.          (set! select-box (list (list init-x init-y scaled-x init-y #t #f)
  229.                                 (list scaled-x init-y scaled-x scaled-y #t #f)
  230.                                 (list scaled-x scaled-y init-x scaled-y #t #f)
  231.                                 (list init-x scaled-y init-x init-y #t #f)))
  232.          (send this refresh))
  233.         (start-panning?
  234.          (set! init-x x)
  235.          (set! init-y y)
  236.          (send dc draw-point scaled-x scaled-y))
  237.         (end-panning?
  238.          (send this set-cursor (make-object cursor% 'arrow))
  239.          (set! x-offset (vector-ref (send dc get-transformation) 1))
  240.          (set! y-offset (vector-ref (send dc get-transformation) 2)))
  241.         (is-panning?
  242.          (let* ((current-x (- x init-x))
  243.                 (current-y (- y init-y)))
  244.            (send this set-cursor (make-object cursor% 'hand))
  245.            (send dc set-transformation (vector transformation-matrix (+ current-x x-offset) (+ current-y y-offset) x-scale y-scale rotation))
  246.            (send this refresh)))))
  247.  
  248.     (define/override (on-paint)
  249.        (send dc set-brush no-brush)
  250.       (when display-select-box (draw-select-box select-box))
  251.       (draw-objects search-list)
  252.       (send dc set-pen normal-pen))
  253.  
  254.     (super-instantiate ())))
  255.  
  256. (define top-frame (new frame%
  257.                        [label "KR"]
  258.                        [width 800]
  259.                        [height 600]
  260.                        [alignment (list 'left 'top)]))
  261. (send top-frame show #t)
  262.  
  263. (define menu-bar (new menu-bar%
  264.                       (parent top-frame)))
  265.  
  266. (define file (new menu%
  267.                   (label "&File")
  268.                   (parent menu-bar)))
  269.  
  270. (define (open-file input-port)
  271.   (new my-canvas%
  272.        (search-list (file->struct-list input-port))
  273.        (x-offset 0)
  274.        (y-offset 0)
  275.        (drawing-scale 1)
  276.        [x-scale 1]
  277.        [y-scale -1]
  278.        [display-select-box #f]
  279.        [select-box '()]))
  280.  
  281. (new menu-item%
  282.      (label "&Open DXF File ")
  283.      (parent file)
  284.      (callback (lambda (b e)
  285.                  (define input-port-or-not (send open run))
  286.                  (when input-port-or-not
  287.                    (open-file input-port-or-not)))))
  288.  
  289.  
  290. (define open (new path-dialog%
  291.                   [existing? #t]
  292.                   [filters (list (list "DXF Files" "*.dxf") (list "Text Files" "*.txt"))]))

=>