blob: 84a9e81e36f99b2bbc83770d4b565563e5598ca1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
(ql:quickload 'cl-svg)
(defpackage #:inv (:use :cl) (:export #:main))
(in-package :inv)
(defmacro define-area-class (name &rest slots)
`(defclass ,name ()
,(loop for slot in slots
collect `(,slot :initarg ,(intern (string-upcase (symbol-name slot)) :keyword)
:initform (error "please provide a value for ~a" ',slot)
:accessor ,(intern (concatenate 'string (symbol-name name)
"-"
(symbol-name slot)))))))
(define-area-class area name points subs)
(defmacro poly (name &key points subs)
`(make-instance 'area :name ,name :points ,points :subs ,subs))
(defmethod print-object ((obj area) out)
(print-unreadable-object (obj out :type t)
(format out "name:~s points:~a subs:~d"
(area-name obj) (area-points obj) (length (area-subs obj)))))
(defun draw-room-with-subs (&key scene area offset-x offset-y scale)
(if area
(svg:transform (svg:scale scale)
(svg:draw scene
(:polygon
:points (format nil "~{~A~^ ~}"
(mapcar
(lambda (point)
(format nil "~A,~A" (first point) (second point)))
(mapcar
(lambda (coord)
(list
(+ (first coord) offset-x)
(+ (second coord) offset-y)))
(area-points area))))
:fill "green"
:stroke "red"
:stroke-width 1))))
(if area
(loop for sub in (area-subs area)
do (draw-room-with-subs
:scene scene
:area sub
:offset-x (first (first (area-points area)))
:offset-y (first (second (area-points area)))
:scale scale))))
; define the floorplan here
; do note: sub-room locations are relative to their parent
(defparameter floorplan
(poly "main" :points '((0 0) (100 0) (100 100 (0 200) (0 0)))
:subs (list (poly "room-1" :points '((10 20) (20 10) (20 20) (10 20)) :subs '())
(poly "room-2" :points '((0 10) (20 40)) :subs '())
(poly "room-3" :points '((5 0) (5 5)) :subs '())
(poly "room-4" :points '((10 0) (5 10)) :subs '()))))
(defparameter floorplan (macroexpand-1
(with-open-file (in "floorplan.lisp") (read in))))
(let ((scene (svg:make-svg-toplevel 'svg:svg-1.1-toplevel :height 1000 :width 1000
:viewbox "0 0 1000 1000")))
(svg:title scene "Floorplan")
(draw-room-with-subs
:scene scene
:area floorplan
:offset-x 0
:offset-y 0
:scale 5)
(with-open-file (s #p"map.svg" :direction :output :if-exists :supersede)
(svg:stream-out s scene)))
|
