PasteRack.org
Paste # 10455
2015-03-26 10:39:12

Fork as a new paste.

Paste viewed 559 times.


Embed:

  1. ;this is read_dxf.rkt
  2.  
  3. ;; This module reads DXF files and extracts any relevant information. Also creates DXF structs
  4.  
  5. (require srfi/1
  6.          2htdp/batch-io
  7.          "structs.rkt"
  8.          "geometric_functions.rkt")
  9.  
  10. (define supported-types '("LWPOLYLINE" "ARC" "POINT" "CIRCLE" "LINE"))
  11. (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"))
  12. (define sections (list "ENTITIES" "ENDSEC"))
  13.  
  14. (provide file->struct-list)
  15.  
  16. ;; parsing functions
  17. (define (split str [ptn #rx"[ ]+"])
  18.   (regexp-split ptn (string-trim str)))
  19.  
  20. (define (reader input-port)
  21.   (define lines (read-chunks input-port))
  22.   (foldl (lambda (f r)
  23.            (define fst (filter (compose not (curry string=? "")) (split f)))
  24.            (append fst r))
  25.          '() lines))
  26.  
  27. (define (read-chunks input-port)
  28.   (let loop ([accu '()])
  29.     (define nxt (read-line input-port 'any))
  30.     (if (eof-object? nxt)
  31.         ((lambda (x) x) accu)
  32.         (loop (cons nxt accu)))))
  33.  
  34. ;; extract the values in one section into a list.
  35. (define (extract-section lst header)
  36.   (define (extract-until lst keyword)
  37.     (cond ((equal? (car lst) keyword) '())
  38.           (else (cons (car lst) (extract-until (cdr lst) keyword)))))
  39.   (extract-until (member (car header) lst) (cadr header)))
  40.  
  41. ;; extract individual entities in the ENTITIES section of a DXF file.
  42. ;; this returns a list of lists, with each containing the information of a single entity.
  43. (define (separate-entities lst)
  44.   (if (empty? lst)
  45.       '()
  46.       (let-values ([(data tail) (break (lambda (element) (member element entity-types)) (rest lst))])
  47.         (if (member (first lst) supported-types)
  48.             (begin (cons (cons (first lst) data)
  49.                          (separate-entities tail)))
  50.             (separate-entities tail)))))
  51.  
  52. ;; lists of DXF entities come in the format: header-keyvalue header-keyvalue ... header-keyvalue
  53.  
  54. ;forgotten purpose
  55. (define (string-contains-alphabet? str)
  56.   (ormap char-alphabetic? (string->list str)))
  57.  
  58. ;; take the pair of the relevant headers for drawing using take-pair,
  59. (define (take-pair lst)
  60.   (cond ((> 2 (length lst)) '())
  61.         (else (cons (list (first lst)
  62.                           (if (string-contains-alphabet? (second lst)) (second lst) (string->number (second lst))))
  63.                     (take-pair (cddr lst))))))
  64.  
  65. ;; and extract the parameters using filter-header
  66. (define (filter-header lst key)
  67.   (cond ((empty? lst) '())
  68.         ((member (car (car lst)) key)
  69.          (cons (car lst)
  70.                (filter-header (cdr lst) key)))
  71.         (else
  72.          (filter-header (cdr lst) key))))
  73.  
  74. (define (list->dxf-line lst)
  75.   (apply create-dxf-line
  76.          (map cadr (filter-header (take-pair lst) '("8" "10" "20" "11" "21")))))
  77.  
  78. (define (list->dxf-arc lst)
  79.   (apply create-dxf-arc
  80.          (map cadr (filter-header (take-pair lst) '("8" "10" "20" "40" "50" "51")))))
  81.  
  82. (define (list->dxf-circle lst)
  83.   (apply create-dxf-circle
  84.          (map cadr (filter-header (take-pair lst) '("8" "10" "20" "40")))))
  85.  
  86. (define (list->dxf-point lst)
  87.   (apply create-dxf-point
  88.          (map cadr (filter-header (take-pair lst) '("8" "10" "20")))))
  89.  
  90. ; 1) if 70 = 1 or 129 then closed. store x y value
  91. ; 2) create line for 10 20 10 20
  92. ; 3) create arc for 10 20 42 10 20
  93. (define (separate-lwpolyline lst layer)
  94.   (define (closed-polyline lst first-x first-y)
  95.     (match lst
  96.       [(list (list "10" x1) (list "20" y1) (list "42" bulge) (list "10" x2) (list "20" y2) a ...)  (cons (create-dxf-arc2 layer x1 y1 x2 y2 bulge) (closed-polyline (append (list (list "10" x2) (list "20" y2)) a) first-x first-y))]
  97.       [(list (list "10" x1) (list "20" y1) (list "10" x2) (list "20" y2) a ...)                    (cons (create-dxf-line layer x1 y1 x2 y2) (closed-polyline (append (list (list "10" x2) (list "20" y2)) a) first-x first-y))]
  98.       [(list (list "10" x1) (list "20" y1) (list "42" bulge))                                      (create-dxf-arc2 layer x1 y1 first-x first-y bulge)]
  99.       [(list (list "10" x1) (list "20" y1))                                                        (create-dxf-line layer x1 y1 first-x first-y)]
  100.       [_ (void)]))
  101.   (define (open-polyline lst)
  102.     (match lst
  103.       [(list (list "10" x1) (list "20" y1) (list "42" bulge) (list "10" x2) (list "20" y2))        (create-dxf-arc2 layer x1 y1 x2 y2 bulge)]
  104.       [(list (list "10" x1) (list "20" y1) (list "10" x2) (list "20" y2))                          (create-dxf-line layer x1 y1 x2 y2)]
  105.       [(list (list "10" x1) (list "20" y1) (list "42" bulge) (list "10" x2) (list "20" y2) a ...)  (cons (create-dxf-arc2 layer x1 y1 x2 y2 bulge) (open-polyline (append (list (list "10" x2) (list "20" y2)) a)))]
  106.       [(list (list "10" x1) (list "20" y1) (list "10" x2) (list "20" y2) a ...)                    (cons (create-dxf-line layer x1 y1 x2 y2) (open-polyline (append (list (list "10" x2) (list "20" y2)) a)))]
  107.       [(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")]
  108.       [_ (void)]))
  109.   (let* ((polyline-flag (cadr (findf (lambda (x) (equal? (car x) "70")) lst)))
  110.          (closed? (if (equal? polyline-flag (or 1 129)) #t #f))
  111.          (first-x (cadr (findf (lambda (x) (equal? (car x) "10")) lst)))
  112.          (first-y (cadr (findf (lambda (x) (equal? (car x) "20")) lst)))) ;1 or 129 for closed, 0 for open
  113.     (if closed?
  114.         (closed-polyline (cdr lst) first-x first-y)
  115.         (open-polyline (cdr lst)))))
  116.  
  117. (define (list->dxf-lwpolyline lst)
  118.   (separate-lwpolyline
  119.    (filter-header (take-pair lst) '("70" "10" "20" "42"))
  120.    (cadr (car (filter-header (take-pair lst) '("8"))))))
  121.  
  122. (define (layer->string x)
  123.   (if (string? x) x (number->string x)))
  124.  
  125. ;; 1) determine the center point of the arc given the angle and the 2 arc points.
  126. ;; 1.1) calculate the 2 possible center points using vectors. the 2 arc points form a line/chord.
  127. ;; 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.
  128. ;; 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)
  129. ;; 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
  130. ;; 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
  131. ;; 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.
  132. ;; 3) calculate the angle from start point to x axis.
  133. ;; 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.
  134. (define (create-dxf-arc2 layer x1 y1 x2 y2 bulge)
  135.   (define (get-center angle big-bulge?)
  136.     (let* ((chord-length (sqrt (+ (expt (- x1 x2) 2) (expt (- y1 y2) 2))))
  137.            (small-angle (if (< angle pi) angle (- (* 2 pi) angle)))
  138.            ;negative bulge indicates point 1 goes to point 2 in a CW fashion
  139.            (is-cw? (negative? bulge))
  140.            (radius (abs (/ (/ chord-length 2) (sin (/ small-angle 2)))))
  141.            (midpoint-x (/ (+ x1 x2) 2))
  142.            (midpoint-y (/ (+ y1 y2) 2))
  143.            ;normalizing a vector -> calculate length, then divide each of its xy components by its length
  144.            (vector-x (- x1 x2))
  145.            (vector-y (- y1 y2))
  146.            (magnitude chord-length)
  147.            (unit-vector-x (* vector-x (/ 1 magnitude)))
  148.            (unit-vector-y (* vector-y (/ 1 magnitude)))
  149.            ;the normal is perpendicular to the vector formed by the 2 arc points
  150.            (normal-vector-x (* 1 unit-vector-y))
  151.            (normal-vector-y (* -1 unit-vector-x))
  152.            (adj (/ (/ chord-length 2) (tan (/ angle 2))))
  153.            ;2 possible center points
  154.            (center1-x (+ midpoint-x (* adj normal-vector-x)))
  155.            (center1-y (+ midpoint-y (* adj normal-vector-y)))
  156.            (center2-x (- midpoint-x (* adj normal-vector-x)))
  157.            (center2-y (- midpoint-y (* adj normal-vector-y)))
  158.            (ax1 (radians->degrees (cos (/ (- x1 center2-x) radius))))
  159.            (ax2 (radians->degrees (cos (/ (- x2 center2-x) radius))))
  160.            (cross-product1 (- (* (- x2 x1) (- center1-y y1)) (* (- y2 y1) (- center1-x x1))))
  161.            (cross-product2 (- (* (- x2 x1) (- center2-y y1)) (* (- y2 y1) (- center2-x x1)))))
  162.       (if big-bulge?
  163.           (if is-cw?                         ;big angle -> CW center and CW arc or CCW center and CCW arc
  164.               (if (positive? cross-product1) ;positive cross product means center is CW with respect to point1 -> point 2
  165.                   (list center1-x center1-y radius)
  166.                   (list center2-x center2-y radius))
  167.               (if (negative? cross-product2)
  168.                   (list center2-x center2-y radius)
  169.                   (list center1-x center1-y radius)))
  170.           (if is-cw?                         ;small angle -> CW center and CCW arc or CCW center and CW arc
  171.               (if (positive? cross-product1) ;positive cross product means center is CW with respect to point1 -> point 2
  172.                   (list center2-x center2-y radius)
  173.                   (list center1-x center1-y radius))
  174.               (if (negative? cross-product2)
  175.                   (list center1-x center1-y radius)
  176.                   (list center2-x center2-y radius))))))
  177.   (let* ((arc-angle-rad (abs (* 4 (atan bulge))))
  178.          (big-bulge? (> arc-angle-rad pi))
  179.          (small-angle (if (< arc-angle-rad pi) arc-angle-rad (- (* 2 pi) arc-angle-rad)))
  180.          (is-cw? (negative? bulge))
  181.          (centerpoints (get-center arc-angle-rad big-bulge?))
  182.          (center-x (car centerpoints))
  183.          (center-y (cadr centerpoints))
  184.          (radius (caddr centerpoints))
  185.          (top (+ center-y radius))
  186.          (bottom (- center-y radius))
  187.          (left (- center-x radius))
  188.          (right (+ center-x radius))
  189.          (quad-num (cond ((and (in-between? x1 left center-x) (in-between? y1 top center-y)) 2)
  190.                          ((and (in-between? x1 left center-x) (in-between? y1 bottom center-y)) 3)
  191.                          ((and (in-between? x1 right center-x) (in-between? y1 top center-y)) 1)
  192.                          ((and (in-between? x1 right center-x) (in-between? y1 bottom center-y)) 4)
  193.                          ;0 is for edge cases.
  194.                          ((or (reasonable-equal? x1 left) (reasonable-equal? x1 right) (reasonable-equal? y1 top) (reasonable-equal? y1 bottom)) 0)
  195.                          (else (display "unaccounted for"))))
  196.          (angle-to (acos (/ (abs (- x1 center-x)) radius)))
  197.          (start (radians->degrees (cond ((= quad-num 0)
  198.                                          (cond ((reasonable-equal? x1 left) (degrees->radians 180))
  199.                                                ((reasonable-equal? x1 right) (degrees->radians 0))
  200.                                                ((reasonable-equal? y1 top) (degrees->radians 90))
  201.                                                ((reasonable-equal? y1 bottom) (degrees->radians 270))
  202.                                                (else (display "unaccounted for"))))
  203.                                         ((= quad-num 1) angle-to)
  204.                                         ((= quad-num 2) (- (degrees->radians 180) angle-to))
  205.                                         ((= quad-num 3) (+ (degrees->radians 180) angle-to))
  206.                                         ((= quad-num 4) (- (degrees->radians 360) angle-to)))))
  207.          (end (if is-cw?
  208.                   (if (negative? (- start (radians->degrees arc-angle-rad)))
  209.                       (+ 360 (- start (radians->degrees arc-angle-rad)))
  210.                       (- start (radians->degrees arc-angle-rad)))
  211.                   (if (< 360 (+ start (radians->degrees arc-angle-rad)))
  212.                       (- (+ start (radians->degrees arc-angle-rad)) 360)
  213.                       (+ start (radians->degrees arc-angle-rad))))))
  214.     ;DXF is CW
  215.     (list (if is-cw?
  216.               (create-dxf-arc layer center-x center-y radius end start)
  217.               (create-dxf-arc layer center-x center-y radius start end)))))
  218.  
  219. (define (create-dxf-line layer x1 y1 x2 y2)
  220.   (dxf-line (layer->string layer) x1 y1 x2 y2))
  221.  
  222. (define (create-dxf-point layer x y)
  223.   (dxf-point (layer->string layer) x y))
  224.  
  225. (define (create-dxf-arc layer x y radius start end)
  226.   (dxf-arc (layer->string layer) x y radius start end))
  227.  
  228. (define (create-dxf-circle layer x y radius) ; creating 2 semicircles with create-arc
  229.   (create-dxf-arc (layer->string layer) x y radius 0 360))
  230.  
  231. ;; convert entity list to their respective structs using above functions
  232. (define (create-structs entity-list)
  233.   (map (lambda (x) (case (first x)
  234.                      [("LINE")       (list->dxf-line (rest x))]
  235.                      [("LWPOLYLINE") (list->dxf-lwpolyline (rest x))]
  236.                      [("CIRCLE")     (list->dxf-circle (rest x))]
  237.                      [("POINT")      (list->dxf-point (rest x))]
  238.                      [("ARC")        (list->dxf-arc (rest x))]))
  239.        entity-list))
  240.  
  241. (define (file->struct-list input-port)
  242.   (let* ((file-list (reader (open-input-file input-port)))
  243.          (section-list (extract-section file-list sections))
  244.          (entity-list (separate-entities section-list)))
  245.     (flatten (create-structs entity-list))))

=>