rectangles.lisp

   1 ;;;; rectangles.lisp
   2
   3 (asdf:oos 'asdf:load-op 'cl-gd)
   4
   5 (defpackage #:rectangles
   6   (:use #:cl))
   7
   8 (in-package #:rectangles)
   9
  10
  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"))
  18
  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)))))))
  56
  57 ;; Represents a chart of rectangles
  58 (defclass chart ()
  59   ((rectangles :initform nil)
  60    (free-rectangle :initform (make-instance 'rectangle) :accessor free-rectangle-of)))
  61
  62
  63 ;; create a chart of rectangles from a property list of data
  64 ;; ( ( "Name" . value ) ...)
  65
  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))))
  92
  93
  94
  95
  96
  97 (asdf:oos 'asdf:load-op 'cl-gd)
  98
  99 (in-package 'cl-gd)
 100
 101
 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)))
 109
 110
 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))
 126                                                  do
 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))))))))
 158
 159
 160
 161
 162
 163
 164
 165