qtree
Автор: treep - 2010-07-23T22:24:26.000000+04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package #:cl-vectorizer)
(defconstant +orients+ '(nw ne sw se))
(defconstant +white-color+ 0)
(defconstant +black-color+ 1)
;;;; qtree node
(defclass qtree-node ()
((size :accessor size-of :initarg :size :initform 1)
(level :reader level-of :initarg :level :initform 1)
(label :reader label-of :initarg :label :initform 0)
(orient :reader orient-of :initarg :orient :initform (first +orients+))
(path :reader path-of :initarg :path :initform nil)
(density :reader density-of :initarg :density :initform nil)
(color :accessor color-of :initarg :color :initform nil)
(parent :reader parent-of :initarg :parent :initform nil)
(childs :accessor childs-of :initform '(nil nil nil nil)))
(:documentation "Quadtree base element."))
(defmethod print-object ((node qtree-node) stream)
(print-unreadable-object (node stream :type t)
(format stream "SIZE: ~A, LEVEL: ~A, LABEL: ~A"
(size-of node)
(level-of node)
(label-of node))))
(defgeneric get-leaf (qtree-node path) (:documentation "Get tree element by path."))
(defgeneric add-pixel (qtree-node x y &optional color) (:documentation "Add pixel to quadtree."))
(defun my-make-list (size index value &key initial-element)
`(,@(make-list index :initial-element initial-element)
,value
,@(make-list (- size index 1) :initial-element initial-element)))
(defmethod add-pixel ((node qtree-node) x y &optional (color +black-color+))
(if (= 1 (size-of node))
(setf (color-of node) color)
(let ((half-size (/ (size-of node) 2))
(index 3))
(cond
((and ; nw - first half
(< x half-size)
(< y half-size))
(setf index 0))
((and ; ne - second half
(>= x half-size)
(< y half-size))
(setf index 1)
(setf x (- half-size x)))
((and ; sw - third half
(< x half-size)
(>= y half-size))
(setf index 2)
(setf y (- half-size y)))
(t ; se fourth half, index already set in let
(setf x (- half-size x))
(setf y (- half-size y))))
(when (null (nth index (childs-of node)))
(let ((child (make-instance 'qtree-node
:size half-size
:level (1+ (level-of node))
:parent node
:color +white-color+
:orient index)))
(setf (childs-of node) (my-make-list 4 index child))))
(let ((new-root (first (childs-of node))))
(when (equal node (first (childs-of node)))
(error "WTF?!! root = new-root"))
(when new-root
(let ((child (add-pixel new-root x y color)))
(setf (childs-of node) (my-make-list 4 0 child)))))
node)))
;;; qtree
(defclass qtree (qtree-node)
((image-hash :accessor image-hash-of :initarg :image-hash :initform nil))
(:documentation "Quadtree class."))
(defmethod print-object ((qtree qtree) stream)
(print-unreadable-object (qtree stream :type t)
(format stream "IMAGE-HASH: ~A"
(image-hash-of qtree))))
(defmethod initialize-instance :after ((qtree qtree) &key image-hash width height)
(labels ((calculate-tree-size (value &optional (size 2))
(if (> value size)
(calculate-tree-size value (* 2 size))
size)))
(setf (image-hash-of qtree) image-hash)
(setf (size-of qtree) (calculate-tree-size (max width height)))))
(defgeneric dump (qtree filename) (:documentation "Dump tree to a file."))
(defgeneric feel (qtree point))
(defgeneric store (qtree &key output-file))
(defmethod feel ((qtree qtree) point)
(loop for point being the hash-key of (image-hash-of qtree) do
(add-pixel qtree (first point) (second point))))
(defmethod store ((qtree qtree) &key (output-file "...png"))
"Store a quadtree of image to file."
;; like make-qt there
;; ...
(in-package #:cl-vectorizer)
(defconstant +orients+ '(nw ne sw se))
(defconstant +white-color+ 0)
(defconstant +black-color+ 1)
;;;; qtree node
(defclass qtree-node ()
((size :accessor size-of :initarg :size :initform 1)
(level :reader level-of :initarg :level :initform 1)
(label :reader label-of :initarg :label :initform 0)
(orient :reader orient-of :initarg :orient :initform (first +orients+))
(path :reader path-of :initarg :path :initform nil)
(density :reader density-of :initarg :density :initform nil)
(color :accessor color-of :initarg :color :initform nil)
(parent :reader parent-of :initarg :parent :initform nil)
(childs :accessor childs-of :initform '(nil nil nil nil)))
(:documentation "Quadtree base element."))
(defmethod print-object ((node qtree-node) stream)
(print-unreadable-object (node stream :type t)
(format stream "SIZE: ~A, LEVEL: ~A, LABEL: ~A"
(size-of node)
(level-of node)
(label-of node))))
(defgeneric get-leaf (qtree-node path) (:documentation "Get tree element by path."))
(defgeneric add-pixel (qtree-node x y &optional color) (:documentation "Add pixel to quadtree."))
(defun my-make-list (size index value &key initial-element)
`(,@(make-list index :initial-element initial-element)
,value
,@(make-list (- size index 1) :initial-element initial-element)))
(defmethod add-pixel ((node qtree-node) x y &optional (color +black-color+))
(if (= 1 (size-of node))
(setf (color-of node) color)
(let ((half-size (/ (size-of node) 2))
(index 3))
(cond
((and ; nw - first half
(< x half-size)
(< y half-size))
(setf index 0))
((and ; ne - second half
(>= x half-size)
(< y half-size))
(setf index 1)
(setf x (- half-size x)))
((and ; sw - third half
(< x half-size)
(>= y half-size))
(setf index 2)
(setf y (- half-size y)))
(t ; se fourth half, index already set in let
(setf x (- half-size x))
(setf y (- half-size y))))
(when (null (nth index (childs-of node)))
(let ((child (make-instance 'qtree-node
:size half-size
:level (1+ (level-of node))
:parent node
:color +white-color+
:orient index)))
(setf (childs-of node) (my-make-list 4 index child))))
(let ((new-root (first (childs-of node))))
(when (equal node (first (childs-of node)))
(error "WTF?!! root = new-root"))
(when new-root
(let ((child (add-pixel new-root x y color)))
(setf (childs-of node) (my-make-list 4 0 child)))))
node)))
;;; qtree
(defclass qtree (qtree-node)
((image-hash :accessor image-hash-of :initarg :image-hash :initform nil))
(:documentation "Quadtree class."))
(defmethod print-object ((qtree qtree) stream)
(print-unreadable-object (qtree stream :type t)
(format stream "IMAGE-HASH: ~A"
(image-hash-of qtree))))
(defmethod initialize-instance :after ((qtree qtree) &key image-hash width height)
(labels ((calculate-tree-size (value &optional (size 2))
(if (> value size)
(calculate-tree-size value (* 2 size))
size)))
(setf (image-hash-of qtree) image-hash)
(setf (size-of qtree) (calculate-tree-size (max width height)))))
(defgeneric dump (qtree filename) (:documentation "Dump tree to a file."))
(defgeneric feel (qtree point))
(defgeneric store (qtree &key output-file))
(defmethod feel ((qtree qtree) point)
(loop for point being the hash-key of (image-hash-of qtree) do
(add-pixel qtree (first point) (second point))))
(defmethod store ((qtree qtree) &key (output-file "...png"))
"Store a quadtree of image to file."
;; like make-qt there
;; ...