[bknr-cvs] hans changed trunk/projects/bos/m2/
BKNR Commits
bknr at bknr.net
Mon Jul 28 14:31:11 UTC 2008
Revision: 3661
Author: hans
URL: http://bknr.net/trac/changeset/3661
Remove old graphics generation files that are no longer useful.
D trunk/projects/bos/m2/bitmap.lisp
U trunk/projects/bos/m2/bos.m2.asd
U trunk/projects/bos/m2/packages.lisp
Deleted: trunk/projects/bos/m2/bitmap.lisp
===================================================================
--- trunk/projects/bos/m2/bitmap.lisp 2008-07-28 14:20:06 UTC (rev 3660)
+++ trunk/projects/bos/m2/bitmap.lisp 2008-07-28 14:31:11 UTC (rev 3661)
@@ -1,200 +0,0 @@
-;;; Anleitung:
-;;; * (write-allocation-bitmaps ...)
-;;; $ mogrify -format gif test-*.png # pkg_add -r ImageMagick
-;;; $ whirlgif -o test.gif test-???.gif # pkg_add -r whirlgif
-;;; Heraus kommt ein animated gif aller Contracts in Erzeugungsreihenfolge,
-;;; die im angegebenen Rechteck sichtbar sind (siehe Argumente zu W-A-B).
-
-(in-package :bos.m2)
-
-(defun make-vga-colors (&optional (image cl-gd:*default-image*))
- (cl-gd:with-default-image (image)
- (let ((colors (make-array 16)))
- (setf (elt colors 01) (cl-gd:find-color #xff #xff #xff :resolve t))
- (setf (elt colors 02) (cl-gd:find-color #xff #x00 #x00 :resolve t))
- (setf (elt colors 03) (cl-gd:find-color #x00 #xff #x00 :resolve t))
- (setf (elt colors 04) (cl-gd:find-color #x00 #x00 #xff :resolve t))
- (setf (elt colors 05) (cl-gd:find-color #x00 #xff #xff :resolve t))
- (setf (elt colors 06) (cl-gd:find-color #xff #x00 #xff :resolve t))
- (setf (elt colors 07) (cl-gd:find-color #xff #xff #x00 :resolve t))
- (setf (elt colors 08) (cl-gd:find-color #x80 #x80 #x80 :resolve t))
- (setf (elt colors 09) (cl-gd:find-color #xc0 #xc0 #xc0 :resolve t))
- (setf (elt colors 10) (cl-gd:find-color #x80 #x00 #x00 :resolve t))
- (setf (elt colors 11) (cl-gd:find-color #x00 #x80 #x00 :resolve t))
- (setf (elt colors 12) (cl-gd:find-color #x00 #x00 #x80 :resolve t))
- (setf (elt colors 13) (cl-gd:find-color #x00 #x80 #x80 :resolve t))
- (setf (elt colors 14) (cl-gd:find-color #x80 #x00 #x80 :resolve t))
- (setf (elt colors 15) (cl-gd:find-color #x80 #x80 #x00 :resolve t))
- colors)))
-
-(defvar *bitmap* nil)
-
-(defun make-allocation-bitmap (left top width height)
- (let ((image (cl-gd:create-image width height)))
- (cl-gd:with-default-image (image)
- (let ((colors (make-vga-colors image)))
- (cl-gd:draw-rectangle* 0 0 (1- width) (1- height)
- :filled t
- :color (elt colors 0))
- (setf *bitmap*
- (list image left top width height colors (make-hash-table)))))))
-
-(defun free-allocation-bitmap ()
- (cl-gd:destroy-image (car *bitmap*))
- (setf *bitmap* nil)
- nil)
-
-(defun all-contracts ()
- (store-objects-with-class 'contract))
-
-(defun draw-contracts (image left top width height colors contracts &optional seen)
- (cl-gd:with-default-image (image)
- ;; We manipulate pixels in a temporary array which is copied to the GD image as
- ;; a whole for performance reasons. The FFI is way too slow to manipulate individual pixels.
- (let ((work-array (make-array (list width height) :element-type 'fixnum)))
- (cl-gd:do-rows (y)
- (cl-gd:do-pixels-in-row (x)
- (setf (aref work-array x y) (cl-gd:raw-pixel))))
- (flet ((set-pixel (x y color)
- (decf x left)
- (decf y top)
- (when (and (<= 0 x (1- width)) (<= 0 y (1- height)))
- (setf (aref work-array x y) color)))
- (get-pixel (x y)
- (decf x left)
- (decf y top)
- (if (and (<= 0 x (1- width)) (<= 0 y (1- height)))
- (aref work-array x y)
- nil)))
- (loop for contract in contracts
- do (when (or (not seen)
- (not (gethash contract seen)))
- (when seen (setf (gethash contract seen) t))
- (let ((free (copy-seq (cdr (coerce colors 'list)))))
- (dolist (m2 (contract-m2s contract))
- (flet ((doit (x y)
- (let ((c (get-pixel x y)))
- (when c
- (setf free (delete c free))))))
- (doit (+ (m2-x m2) 0) (+ (m2-y m2) -1))
- (doit (+ (m2-x m2) -1) (+ (m2-y m2) 0))
- (doit (+ (m2-x m2) +1) (+ (m2-y m2) 0))
- (doit (+ (m2-x m2) 0) (+ (m2-y m2) +1))))
- (let ((color (or (car free)
- (elt colors (1+ (random 15))))))
- (dolist (m2 (contract-m2s contract))
- (set-pixel (m2-x m2) (m2-y m2) color)))))))
- (cl-gd:do-rows (y)
- (cl-gd:do-pixels-in-row (x)
- (setf (cl-gd:raw-pixel) (aref work-array x y)))))))
-
-(defun write-allocation-bitmap (filename &optional ncontracts)
- (destructuring-bind (image left top width height colors seen) *bitmap*
- (let ((contracts (sort (copy-list (all-contracts)) #'< :key #'store-object-id)))
- (draw-contracts image left top width height colors (subseq contracts 0 ncontracts) seen)
- (when (probe-file filename)
- (delete-file filename))
- (cl-gd:write-image-to-file filename :image image :type :png))
- filename))
-
-(defun draw-stripes ()
- (destructuring-bind (image left top width height colors seen) *bitmap*
- (declare (ignore left top width height seen))
- (cl-gd:with-default-image (image)
- (dolist (stripe (store-stripes))
- (with-slots (left top width height) stripe
- (cl-gd:draw-rectangle* left top (1- (+ left width)) (1- (+ top height))
- :color (elt colors 1)))))))
-
-(defun write-allocation-bitmaps
- (&key (step 100) left top width height draw-stripes
- (directory "/home/david/animate/"))
- (when *bitmap*
- (free-allocation-bitmap))
- (unless (and left top width height)
- ;; automatisch den kleinesten ausschnitt waehlen, der alle allocation
- ;; areas enthaelt, falls nicht anders vorgegeben.
- (let ((points '()))
- (dolist (area (all-allocation-areas))
- (with-slots (left top width height) area
- (push (cons left top) points)
- (push (cons (+ left width) (+ top height)) points)))
- (multiple-value-setq (left top width height)
- (compute-bounding-box points))))
- (make-allocation-bitmap left top width height)
- (when draw-stripes
- (draw-stripes))
- (if step
- (loop for i from 0 to (ceiling (length (all-contracts)) step)
- do
- (let ((filename
- (merge-pathnames (format nil "test-~3,'0D.png" i)
- directory)))
- (print filename)
- (force-output)
- (write-allocation-bitmap filename (* i step))))
- (write-allocation-bitmap
- (merge-pathnames "test.png" directory))))
-
-(defvar *initial-random-state* (make-random-state))
-
-(defun test-allocation
- (&key (initial-random-state *initial-random-state*)
- (limit nil))
- (let ((*random-state* (make-random-state initial-random-state)))
- (when *bitmap*
- (free-allocation-bitmap))
- (make-allocation-bitmap 0 0 400 400)
- (let ((u (or (find-user 123)
- (make-sponsor :profile-id 123
- :first-name "Otto"
- :last-name "Mustermann"
- :email-address "otto.mustermann at t-online.de"))))
- (flet ((make-one-contract ()
- (let* ((limit 0.0001)
- (n (max 1 (round (/ 0.5 (+ (random (- 1.0 limit)) limit))))))
-
- (format t " ~D" n)
- (force-output)
- (make-contract u n))))
- (if limit
- (dotimes (x limit)
- (make-one-contract))
- (loop
- (make-one-contract)))))))
-
-#+(or)
-(progn
- (reinit :delete t :directory "home:tmp/mytest-datastore/")
- (let ((p #((66 . 0) (134 . 0)
- (200 . 66) (200 . 134)
- (134 . 200) (66 . 200)
- (0 . 134) (0 . 66)))
- (q #((200 . 180) (400 . 0) (400 . 200)))
- (r (map 'vector
- (lambda (x)
- (cons (+ (* (car x) 40) 20)
- (+ (* (cdr x) 40) 200)))
- #((0 . 0) (1 . 0) (1 . 3) (2 . 4) (3 . 3) (3 . 0) (4 . 0)
- (4 . 4) (2 . 5) (0 . 4))))
- (s #((400 . 0) (600 . 0) (600 . 200) (400 . 200))))
- (bknr.datastore::without-sync ()
- (make-allocation-area p)
- (make-allocation-area q)
- (make-allocation-area r)
- (make-allocation-area s)))
- (bknr.datastore::without-sync ()
- (time
- (with-simple-restart (ok "ok")
- (test-allocation :limit nil)))))
-
-#+(or)
-(bknr.datastore::without-sync ()
- (make-allocation-area
- #((66 . 0) (134 . 0)
- (200 . 66) (200 . 134)
- (134 . 200) (66 . 200)
- (0 . 134) (0 . 66))))
-
-#+(or)
-(bos.m2::make-allocation-area #((0 . 0) (200 . 0) (200 . 200) (0 . 200)))
Modified: trunk/projects/bos/m2/bos.m2.asd
===================================================================
--- trunk/projects/bos/m2/bos.m2.asd 2008-07-28 14:20:06 UTC (rev 3660)
+++ trunk/projects/bos/m2/bos.m2.asd 2008-07-28 14:31:11 UTC (rev 3661)
@@ -1,34 +1,35 @@
- (in-package :cl-user)
+;; -*- Lisp -*-
- (asdf:defsystem :bos.m2
- :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime
- :kmrcl :iterate :arnesi
- :cl-pdf :screamer :cl-fad)
- :components ((:file "packages")
- (:file "geo-utm" :depends-on ("packages"))
- (:file "geometry" :depends-on ("packages" "m2-store"))
- (:file "config" :depends-on ("packages"))
- (:file "utils" :depends-on ("config"))
- (:file "news" :depends-on ("poi"))
- (:file "tiled-index" :depends-on ("config"))
- (:file "mail-generator" :depends-on ("config"))
- (:file "make-certificate" :depends-on ("config"))
- (:file "initialization-subsystem" :depends-on ("packages"))
- (:file "m2-store" :depends-on ("packages" "utils"))
- (:file "m2" :depends-on ("initialization-subsystem"
- "tiled-index"
- "utils"
- "make-certificate"
- "mail-generator"
- "geo-utm"
- "geometry"))
- (:file "m2-pdf" :depends-on ("m2"))
- (:file "contract-expiry" :depends-on ("m2"))
- (:file "allocation" :depends-on ("m2"))
- (:file "allocation-cache" :depends-on ("packages" "geometry"))
- (:file "poi" :depends-on ("utils" "allocation"))
- (:file "bitmap" :depends-on ("allocation"))
- (:file "import" :depends-on ("m2"))
- (:file "map" :depends-on ("m2" "allocation" "geometry"))
- (:file "export" :depends-on ("m2"))
- (:file "cert-daemon" :depends-on ("config"))))
+(in-package :cl-user)
+
+(asdf:defsystem :bos.m2
+ :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime
+ :kmrcl :iterate :arnesi
+ :cl-pdf :screamer :cl-fad)
+ :components ((:file "packages")
+ (:file "geo-utm" :depends-on ("packages"))
+ (:file "geometry" :depends-on ("packages" "m2-store"))
+ (:file "config" :depends-on ("packages"))
+ (:file "utils" :depends-on ("config"))
+ (:file "news" :depends-on ("poi"))
+ (:file "tiled-index" :depends-on ("config"))
+ (:file "mail-generator" :depends-on ("config"))
+ (:file "make-certificate" :depends-on ("config"))
+ (:file "initialization-subsystem" :depends-on ("packages"))
+ (:file "m2-store" :depends-on ("packages" "utils"))
+ (:file "m2" :depends-on ("initialization-subsystem"
+ "tiled-index"
+ "utils"
+ "make-certificate"
+ "mail-generator"
+ "geo-utm"
+ "geometry"))
+ (:file "m2-pdf" :depends-on ("m2"))
+ (:file "contract-expiry" :depends-on ("m2"))
+ (:file "allocation" :depends-on ("m2"))
+ (:file "allocation-cache" :depends-on ("packages" "geometry"))
+ (:file "poi" :depends-on ("utils" "allocation"))
+ (:file "import" :depends-on ("m2"))
+ (:file "map" :depends-on ("m2" "allocation" "geometry"))
+ (:file "export" :depends-on ("m2"))
+ (:file "cert-daemon" :depends-on ("config"))))
Modified: trunk/projects/bos/m2/packages.lisp
===================================================================
--- trunk/projects/bos/m2/packages.lisp 2008-07-28 14:20:06 UTC (rev 3660)
+++ trunk/projects/bos/m2/packages.lisp 2008-07-28 14:31:11 UTC (rev 3661)
@@ -200,10 +200,6 @@
#:allocation-area-percent-used
#:left #:top #:width #:height #:active-p
- ;; bitmap routines for drawing of allocation areas
- #:make-vga-colors
- #:draw-contracts
-
;; pois
#:*current-language*
#:slot-string
More information about the Bknr-cvs
mailing list