Initial commit
[yotta-zoomer.git] / rectangles.lisp
blob24e54661657bba5d489bcccd0553fd45866306f4
1 ;;;; rectangles.lisp
3 (asdf:oos 'asdf:load-op 'cl-gd)
5 (defpackage #:rectangles
6 (:use #:cl))
8 (in-package #:rectangles)
11 ;; an abstract named rectangle thing
12 (defclass rectangle ()
13 ((x :accessor x-of :iniform 0 :initarg :x)
14 (y :accessor y-of :initform 0 :initarg :y)
15 (w :accessor width-of :initform 1 :initarg :width)
16 (h :accessor height-of :initform 1 :initarg :height)
17 (name :accessof name-of :initform "Unknown"))
19 ;; split one rectangle into two. Returns two rectangles,
20 ;; the first of which is the given fraction of the original,
21 ;; the second the remaining area of the original
22 (defmethod split ((self rectangle) fraction &key direction)
23 (ccase direction
24 (:horizontal
25 (let*
26 ((h-top (* (height-of rectangle) fraction))
27 (h-bot (- (height-of rectangle) h-top))
28 (split-y (+ h-top (y-of rectangle))))
29 (values
30 (make-instance 'rectangle
31 :x (x-of rectangle)
32 :y (y-of rectangle)
33 :width (width-of rectangle)
34 :height h-top)
35 (make-instance 'rectangle
36 :x (x-of rectangle)
37 :y split-y
38 :width (width-of rectangle)
39 :height h-bot))))
40 (:vertical
41 (let*
42 ((w-top (* (width-of rectangle) fraction))
43 (w-bot (- (width-of rectangle) w-top))
44 (split-x (+ w-top (x-of rectangle))))
45 (values
46 (make-instance 'rectangle
47 :x (x-of rectangle)
48 :y (y-of rectangle)
49 :width w-top
50 :height (height-of rectangle))
51 (make-instance 'rectangle
52 :x split-x
53 :y (y-of rectangle)
54 :width w-bot
55 :height (height-of rectangle)))))))
57 ;; Represents a chart of rectangles
58 (defclass chart ()
59 ((rectangles :initform nil)
60 (free-rectangle :initform (make-instance 'rectangle) :accessor free-rectangle-of)))
63 ;; create a chart of rectangles from a property list of data
64 ;; ( ( "Name" . value ) ...)
66 (defmethod make-instance ((self chart) &key data)
67 (labels
68 ((sum-data (data)
69 "Return the sum od the data"
70 (reduce #'(lambda (t x) (+ t (cdr x))) data))
71 (normalise-data (sum data)
72 "Normalise the data."
73 (loop
74 for element in data
75 collect (cons (car element) (/ (cdr element) sum))))
76 (normalise (data)
77 "Normalise the data."
78 (normalise-data (sum-data data) data))
79 (split-for-datum (datum &key direction)
80 (multiple-value-bind
81 (taken free)
82 (split (free-rectangle-of self) (cdr datum) :direction direction)
83 (progn
84 (setf (free-rectangle-of self) free)
85 (setf (name-of taken) (car data))
86 (push (rectangles-of self) taken))))
87 (consume-data (data)
88 (when data
89 ((split-for-datum (car data) :horizontal)
90 (consume-data (normalise (rest data))))))
91 (consume-data data))))
97 (asdf:oos 'asdf:load-op 'cl-gd)
99 (in-package 'cl-gd)
102 (defun discretize (data range)
103 (labels
104 ((sum-data (data)
105 (reduce #'+ data))))
106 (let
107 ((result (make-array (array-total-size data))))
108 (map-into result #'(lambda (x) (round (* (/ x (sum-data data))))) range)))
111 (defun region-sample (sample-count region sample-size sample-resolution sample-fn sample-score-fn)
112 (labels
113 ((randomly-place main-region &key within)
114 (make-instance 'rectangle
115 :x (+ (x-of region) (random (- (width-of region) (width-of within))))
116 :y (+ (y-of region) (random (- (height-of region) (height-of within))))
117 :width (width-of within)
118 :height (height-of within))
119 (create-sample (region sample-resolution)
120 (let
121 ((result (make-array (* sample-resolution sample-resolution)
122 :fill-pointer 0
123 :adjustable t)))
124 (loop
125 for x = (x-of region) then (+ x (/ (width-of region) sample-resolution))
127 (loop
128 for y = (y-of region) then (+ y (/ (height-of region) sample-resolution))
129 (vector-push (funcall sample-fn x y))))
130 result))
131 (let*
132 ((sample-region-rectangle
133 (make-instance 'rectangle
134 :width (* (width-of region) sample-size)
135 :height (* (width-of region) sample-size)))
136 (samples
137 (loop
138 for sample-index from 0 below sample-count
139 collect
140 (progn
141 (create-sample
142 (randomly-place sample-region-rectangle :within region)
143 sample-resolution))))
144 (sample-scores
145 (sort
146 (loop
147 for sample in samples
148 for sample-index = 0 then (1+ sample-index)
149 collect
150 (cons
151 (funcall sample-score-fun sample)
152 sample-index))
153 #'< :key #'car)))
154 (loop
155 for score in sample-scores
156 (collect
157 (cons (car score) (nth (car score) samples))))))))