Changeset 3656

Show
Ignore:
Timestamp:
07/28/08 14:31:09 (4 months ago)
Author:
ksprotte
Message:

whitespace cleanup

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/projects/bos/m2/allocation-cache.lisp

    r3638 r3656  
    220220           (misses-perc (round (* 100.0 (/ (float misses) total))))) 
    221221      (format t "cache hits:~15T~5D~25T~3D%~%" hits hits-perc) 
    222       (format t "cache misses:~15T~5D~25T~3D%~3%" misses misses-perc)     
     222      (format t "cache misses:~15T~5D~25T~3D%~3%" misses misses-perc) 
    223223      (format t "CACHE ENTRIES~2%") 
    224224      (format t "number of m2 not in cache: ~A~2%" (ignored-size *allocation-cache*)) 
    …… 
    232232          (format t "~5D~10T~5D~%" size count)))))) 
    233233 
    234 (defun rebuild-allocation-cache ()   
     234(defun rebuild-allocation-cache () 
    235235  (assert (or (in-transaction-p) (eql :snapshot (store-state *store*))) nil 
    236           "rebuild-allocation-cache may only be called in a transaction context")   
     236          "rebuild-allocation-cache may only be called in a transaction context") 
    237237  (unless *allocation-cache* 
    238238    (setq *allocation-cache* (make-allocation-cache))) 
    …… 
    257257      (index-push (length m2s) (make-cache-entry :area allocation-area 
    258258                                                 :region m2s))))) 
    259  

  • trunk/projects/bos/m2/allocation.lisp

    r3639 r3656  
    347347                (m2 (ensure-m2 x y)) 
    348348                (result (search-adjacent n m2 #'allocatable-p))) 
    349              (when result 
    350                (assert (alexandria:setp result :test #'equal)) 
    351                (assert (= n (length result))) 
    352                (decf (allocation-area-free-m2s area) n) 
    353                (return result)) 
    354              (when (> (get-internal-real-time) deadline) 
    355                (return nil))))))) 
     349           (when result 
     350             (assert (alexandria:setp result :test #'equal)) 
     351             (assert (= n (length result))) 
     352             (decf (allocation-area-free-m2s area) n) 
     353             (return result)) 
     354           (when (> (get-internal-real-time) deadline) 
     355             (return nil))))))) 
    356356 
    357357(defun allocate-m2s-for-sale (n) 

  • trunk/projects/bos/m2/bitmap.lisp

    r2098 r3656  
    6868                   nil))) 
    6969        (loop for contract in contracts 
    70              do (when (or (not seen) 
    71                           (not (gethash contract seen))) 
    72                   (when seen (setf (gethash contract seen) t)) 
    73                   (let ((free (copy-seq (cdr (coerce colors 'list))))) 
    74                     (dolist (m2 (contract-m2s contract)) 
    75                       (flet ((doit (x y) 
    76                                (let ((c (get-pixel x y))) 
    77                                  (when c 
    78                                    (setf free (delete c free)))))) 
    79                         (doit (+ (m2-x m2)  0) (+ (m2-y m2) -1)) 
    80                         (doit (+ (m2-x m2) -1) (+ (m2-y m2)  0)) 
    81                         (doit (+ (m2-x m2) +1) (+ (m2-y m2)  0)) 
    82                         (doit (+ (m2-x m2)  0) (+ (m2-y m2) +1)))) 
    83                     (let ((color (or (car free) 
    84                                      (elt colors (1+ (random 15)))))) 
    85                       (dolist (m2 (contract-m2s contract)) 
    86                         (set-pixel (m2-x m2) (m2-y m2) color))))))) 
     70           do (when (or (not seen) 
     71                        (not (gethash contract seen))) 
     72                (when seen (setf (gethash contract seen) t)) 
     73                (let ((free (copy-seq (cdr (coerce colors 'list))))) 
     74                  (dolist (m2 (contract-m2s contract)) 
     75                    (flet ((doit (x y) 
     76                             (let ((c (get-pixel x y))) 
     77                               (when c 
     78                                 (setf free (delete c free)))))) 
     79                      (doit (+ (m2-x m2)  0) (+ (m2-y m2) -1)) 
     80                      (doit (+ (m2-x m2) -1) (+ (m2-y m2)  0)) 
     81                      (doit (+ (m2-x m2) +1) (+ (m2-y m2)  0)) 
     82                      (doit (+ (m2-x m2)  0) (+ (m2-y m2) +1)))) 
     83                  (let ((color (or (car free) 
     84                                   (elt colors (1+ (random 15)))))) 
     85                    (dolist (m2 (contract-m2s contract)) 
     86                      (set-pixel (m2-x m2) (m2-y m2) color))))))) 
    8787      (cl-gd:do-rows (y) 
    8888        (cl-gd:do-pixels-in-row (x) 
    …… 
    127127  (if step 
    128128      (loop for i from 0 to (ceiling (length (all-contracts)) step) 
    129             do 
    130             (let ((filename 
    131                    (merge-pathnames (format nil "test-~3,'0D.png" i) 
    132                                     directory))) 
    133               (print filename) 
    134               (force-output) 
    135               (write-allocation-bitmap filename (* i step)))) 
     129         do 
     130         (let ((filename 
     131                (merge-pathnames (format nil "test-~3,'0D.png" i) 
     132                                 directory))) 
     133           (print filename) 
     134           (force-output) 
     135           (write-allocation-bitmap filename (* i step)))) 
    136136      (write-allocation-bitmap 
    137137       (merge-pathnames "test.png" directory)))) 
    …… 
    141141(defun test-allocation 
    142142    (&key (initial-random-state *initial-random-state*) 
    143           (limit nil)) 
     143     (limit nil)) 
    144144  (let ((*random-state* (make-random-state initial-random-state))) 
    145145    (when *bitmap* 
    …… 
    154154               (let* ((limit 0.0001) 
    155155                      (n (max 1 (round (/ 0.5 (+ (random (- 1.0 limit)) limit)))))) 
    156          
     156 
    157157                 (format t " ~D" n) 
    158158                 (force-output) 
    …… 
    162162              (make-one-contract)) 
    163163            (loop 
    164               (make-one-contract))))))) 
     164              (make-one-contract))))))) 
    165165 
    166166#+(or) 

  • trunk/projects/bos/m2/bos.m2.asd

    r3565 r3656  
    1 (in-package :cl-user) 
     1        (in-package :cl-user) 
    22 
    3 (asdf:defsystem :bos.m2 
    4   :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime 
    5                                :kmrcl :iterate :arnesi 
    6                                :cl-pdf :screamer :cl-fad) 
    7   :components ((:file "packages") 
    8              (:file "geo-utm" :depends-on ("packages")) 
    9              (:file "geometry" :depends-on ("packages" "m2-store"))                
    10              (:file "config" :depends-on ("packages")) 
    11              (:file "utils" :depends-on ("config")) 
    12              (:file "news" :depends-on ("poi")) 
    13              (:file "tiled-index" :depends-on ("config")) 
    14              (:file "mail-generator" :depends-on ("config")) 
    15              (:file "make-certificate" :depends-on ("config")) 
    16              (:file "initialization-subsystem" :depends-on ("packages")) 
    17                (:file "m2-store" :depends-on ("packages" "utils")) 
    18                (:file "m2" :depends-on ("initialization-subsystem" 
    19                                         "tiled-index" 
    20                                       "utils" 
    21                                       "make-certificate" 
    22                                       "mail-generator" 
    23                                       "geo-utm" 
    24                                         "geometry")) 
    25                (:file "m2-pdf" :depends-on ("m2")) 
    26              (:file "contract-expiry" :depends-on ("m2")) 
    27              (:file "allocation" :depends-on ("m2")) 
    28              (:file "allocation-cache" :depends-on ("packages" "geometry")) 
    29              (:file "poi" :depends-on ("utils" "allocation")) 
    30              (:file "bitmap" :depends-on ("allocation")) 
    31              (:file "import" :depends-on ("m2")) 
    32              (:file "map" :depends-on ("m2" "allocation" "geometry")) 
    33              (:file "export" :depends-on ("m2")) 
    34              (:file "cert-daemon" :depends-on ("config")))) 
     3        (asdf:defsystem :bos.m2 
     4          :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime 
     5                                         :kmrcl :iterate :arnesi 
     6                                                                        :cl-pdf :screamer :cl-fad) 
     7                                                                          :components ((:file "packages") 
     8                                                                                     (:file "geo-utm" :depends-on ("packages")) 
     9                                                                                                     (:file "geometry" :depends-on ("packages" "m2-store"))                
     10                                                                                                             (:file "config" :depends-on ("packages")) 
     11                                                                                                                     (:file "utils" :depends-on ("config")) 
     12                                                                                                                             (:file "news" :depends-on ("poi")) 
     13                                                                                                                                     (:file "tiled-index" :depends-on ("config")) 
     14                                                                                                                                             (:file "mail-generator" :depends-on ("config")) 
     15                                                                                                                                                     (:file "make-certificate" :depends-on ("config")) 
     16                                                                                                                                                             (:file "initialization-subsystem" :depends-on ("packages")) 
     17                                                                                                                                                                      (:file "m2-store" :depends-on ("packages" "utils")) 
     18                                                                                                                                                                                     (:file "m2" :depends-on ("initialization-subsystem" 
     19                                                                                                                                                                                                                             "tiled-index" 
     20                                                                                                                                                                                                                                                              "utils" 
     21                                                                                                                                                                                                                                                                                                      "make-certificate" 
     22                                                                                                                                                                                                                                                                                                                                              "mail-generator" 
     23                                                                                                                                                                                                                                                                                                                                                                                      "geo-utm" 
     24                                                                                                                                                                                                                                                                                                                                                                                                                                "geometry")) 
     25                                                                                                                                                                                                                                                                                                                                                                                                                                               (:file "m2-pdf" :depends-on ("m2")) 
     26                                                                                                                                                                                                                                                                                                                                                                                                                                                             (:file "contract-expiry" :depends-on ("m2")) 
     27                                                                                                                                                                                                                                                                                                                                                                                                                                                                     (:file "allocation" :depends-on ("m2")) 
     28                                                                                                                                                                                                                                                                                                                                                                                                                                                                             (:file "allocation-cache" :depends-on ("packages" "geometry")) 
     29                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     (:file "poi" :depends-on ("utils" "allocation")) 
     30                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             (:file "bitmap" :depends-on ("allocation")) 
     31                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     (:file "import" :depends-on ("m2")) 
     32                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             (:file "map" :depends-on ("m2" "allocation" "geometry")) 
     33                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     (:file "export" :depends-on ("m2")) 
     34                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             (:file "cert-daemon" :depends-on ("config")))) 

  • trunk/projects/bos/m2/cert-daemon.lisp

    r3478 r3656  
    4242            (fill-form fdf-pathname 
    4343                       (if (probe-file language-specific-template-pathname) 
    44                                        language-specific-template-pathname 
    45                                        template-pathname) 
     44                           language-specific-template-pathname 
     45                           template-pathname) 
    4646                       m2-pdf-pathname 
    4747                       output-pathname))) 

  • trunk/projects/bos/m2/config.lisp

    r3160 r3656  
    3232(defparameter *pdf-base-directory* (merge-pathnames #p"certs/" (user-homedir-pathname))) 
    3333(defparameter *cert-mail-directory* (merge-pathnames "mail-spool/" *pdf-base-directory*) 
    34              "Verzeichnis fÃŒr per Post zu versendende Urkunden-FDF-Dateien") 
     34  "Verzeichnis fÃŒr per Post zu versendende Urkunden-FDF-Dateien") 
    3535(defparameter *cert-download-directory* (merge-pathnames "download-spool/" *pdf-base-directory*) 
    36              "Verzeichnis fÃŒr Urkunden-FDF-Dateien, aus denen 
     36  "Verzeichnis fÃŒr Urkunden-FDF-Dateien, aus denen 
    3737Download-Urkunden erzeugt werden sollen") 
    3838(defparameter *receipt-mail-directory* (merge-pathnames "receipt-mail-spool/" *pdf-base-directory*) 
    39              "Verzeichnis fÃŒr per Post zu versendende Urkunden-FDF-Dateien") 
     39  "Verzeichnis fÃŒr per Post zu versendende Urkunden-FDF-Dateien") 
    4040(defparameter *receipt-download-directory* (merge-pathnames "receipt-download-spool/" *pdf-base-directory*) 
    41              "Verzeichnis fÃŒr Urkunden-FDF-Dateien, aus denen 
     41  "Verzeichnis fÃŒr Urkunden-FDF-Dateien, aus denen 
    4242Download-Urkunden erzeugt werden sollen") 
    4343 
    4444(defparameter *cert-mail-template* (merge-pathnames #p"urkunde-print.pdf" 
    45                                                   *pdf-base-directory*)) 
     45                                                    *pdf-base-directory*)) 
    4646(defparameter *cert-download-template* (merge-pathnames #p"urkunde-download.pdf" 
    47                                                       *pdf-base-directory*)) 
     47                                                        *pdf-base-directory*)) 
    4848(defparameter *receipt-mail-template* (merge-pathnames #p"spendenbescheinigung-print.pdf" 
    4949                                                       *pdf-base-directory*)) 
    5050(defparameter *receipt-download-template* (merge-pathnames #p"spendenbescheinigung-download.pdf" 
    51                                                       *pdf-base-directory*)) 
     51                                                           *pdf-base-directory*)) 
    5252(defparameter *cert-daemon-poll-seconds* 2 
    5353  "Wartezeit zwischen zwei Directory-Scans des Urkunden-Daemons") 
    …… 
    7474;; Einschalten des Mail-Versands (normalerweise aus) 
    7575(defvar *enable-mails* nil) 
    76  

  • trunk/projects/bos/m2/export.lisp

    r1131 r3656  
    9292      (with-element "polygon" 
    9393        (map nil 
    94             (lambda (vertex) 
    95               (export-point (car vertex) (cdr vertex))) 
    96             vertices)) 
     94            (lambda (vertex) 
     95              (export-point (car vertex) (cdr vertex))) 
     96            vertices)) 
    9797      (with-element "stripes" 
    9898        (map-sorted #'export-stripe #'stripe< stripes))))) 
    …… 
    116116(defun export-database (pathname 
    117117                        &key (indentation 2) 
    118                              (include-database-id *include-database-id*)) 
     118                        (include-database-id *include-database-id*)) 
    119119  (with-open-file (target-stream 
    120120                   pathname 

  • trunk/projects/bos/m2/geo-utm.lisp

    r3041 r3656  
    9191                                 (+ (+ 1 (/ (expt n 2) 4)) (/ (expt n 4) 64)))) 
    9292                      (y_ (/ y alpha_)) 
    93                       beta_ gamma_ delta_ epsilon_)         
     93                      beta_ gamma_ delta_ epsilon_) 
    9494                 (setq beta_ 
    9595                       (+ 
    …… 
    131131                                 (* (* t2 t2) t2))) 
    132132                      (l4 (expt (abs l) 4)) 
    133                       (l5 (* l l4))                       
     133                      (l5 (* l l4)) 
    134134                      (l6 (* l l5)) 
    135135                      (l7 (* l l6)) 
    …… 
    142142                      (expt-cos-phi-6 (* expt-cos-phi-5 cos-phi)) 
    143143                      (expt-cos-phi-7 (* expt-cos-phi-6 cos-phi)) 
    144                       (expt-cos-phi-8 (* expt-cos-phi-7 cos-phi)))             
     144                      (expt-cos-phi-8 (* expt-cos-phi-7 cos-phi))) 
    145145                 (values 
    146146                  (+ 
    …… 
    221221                (setq x8poly 
    222222                      (+ (+ (+ 1385.0 (* 3633.0 tf2)) (* 4095.0 tf4)) 
    223                          (* 1575 (* tf4 tf2))))                 
     223                         (* 1575 (* tf4 tf2)))) 
    224224                (let* ((x4 (expt (abs x) 4)) 
    225225                       (x5 (* x4 x)) 
    …… 
    246246                 ((double-float -90d0 90d0) lat) 
    247247                 (float-pair float-pair)) 
    248         (let ((zone (+ (floor (+ lon 180.0) 6.0) 1)))             
     248        (let ((zone (+ (floor (+ lon 180.0) 6.0) 1))) 
    249249          (multiple-value-bind (x y) 
    250250              (map-lat-lon-to-xy (deg-to-rad lat) (deg-to-rad lon) (utmcentral-meridian zone)) 
    …… 
    255255                  (aref float-pair 1) y) 
    256256            (values float-pair zone (minusp lat))))) 
    257              
     257 
    258258      (defun utm-x-y-to-lon-lat* (x y zone southhemi-p float-pair) 
    259259        "Returns list (LON LAT)." 
    260260        (declare (double-float x y) (float-pair float-pair)) 
    261         (let ((cmeridian (utmcentral-meridian zone)))                     
     261        (let ((cmeridian (utmcentral-meridian zone))) 
    262262          (decf x 500000.0) 
    263263          (dividef x utmscale-factor) 
    …… 
    265265          (dividef y utmscale-factor) 
    266266          (multiple-value-bind (lat lon) 
    267               (map-xyto-lat-lon x y cmeridian)          
     267              (map-xyto-lat-lon x y cmeridian) 
    268268            (setf (aref float-pair 0) (rad-to-deg lon) 
    269269                  (aref float-pair 1) (rad-to-deg lat)) 
    270270            float-pair)))))) 
    271271 
    272 (defun lon-lat-to-utm-x-y (lon lat)     
     272(defun lon-lat-to-utm-x-y (lon lat) 
    273273  (multiple-value-bind (float-pair zone southhemi-p) 
    274274      (lon-lat-to-utm-x-y* (float lon 0d0) (float lat 0d0) (make-float-pair)) 
    …… 
    277277 
    278278(defun utm-x-y-to-lon-lat (x y zone southhemi-p) 
    279   "Returns list (LON LAT)."     
     279  "Returns list (LON LAT)." 
    280280  (let ((lon-lat (utm-x-y-to-lon-lat* (float x 0d0) (float y 0d0) 
    281281                                      zone southhemi-p (make-float-pair)))) 
    282282    (list (aref lon-lat 0) (aref lon-lat 1)))) 
    283283 
    284 (eval-when (:compile-toplevel :load-toplevel :execute)   
     284(eval-when (:compile-toplevel :load-toplevel :execute) 
    285285  (setq *read-default-float-format* *initial-read-default-float-format*)) 
    286  

  • trunk/projects/bos/m2/geometry.lisp

    r3588 r3656  
    447447                     (unless (visited-p neighbour) 
    448448                       (push neighbour stack))) 
    449                    (traverse stack)))))    
     449                   (traverse stack))))) 
    450450      (traverse (list (first nodes))) 
    451451      (= (length nodes) 
    …… 
    462462               else do (princ ".")) 
    463463         do (terpri))))) 
    464  

  • trunk/projects/bos/m2/import.lisp

    r1131 r3656  
    7070       (when y (assert (eql (parse-integer y) (m2-y m2)))) 
    7171       (when utm-x (assert (= (read-from-string utm-x) (m2-utm-x m2)))) 
    72         (when utm-y (assert (= (read-from-string utm-y) (m2-utm-y m2)))) 
     72       (when utm-y (assert (= (read-from-string utm-y) (m2-utm-y m2)))) 
    7373       (push m2 (importer-m2s handler)))) 
    7474    ((string= qname "allocation-area") 

  • trunk/projects/bos/m2/initialization-subsystem.lisp

    r3638 r3656  
    1616have been called." 
    1717  (labels ((ignorant-tie-breaker (choices reverse-partial-solution) 
    18              (declare (ignore reverse-partial-solution))          
     18             (declare (ignore reverse-partial-solution)) 
    1919             ;; we dont care about making any particular choice here - 
    2020             ;; this would be different for computing the class 
    …… 
    2727    (check-type init-function symbol) 
    2828    (dolist (dependency dependencies) 
    29       (check-type dependency symbol))     
     29      (check-type dependency symbol)) 
    3030    (let (new-transient-init-functions 
    3131          new-transient-init-constraints) 
    …… 
    3434            ;; we want to be able to abort without changes 
    3535            (*transient-init-functions* *transient-init-functions*) 
    36             (*transient-init-constraints* *transient-init-constraints*))       
     36            (*transient-init-constraints* *transient-init-constraints*)) 
    3737        (pushnew init-function *transient-init-functions*) 
    3838        (dolist (dependency dependencies) 
    …… 
    7474  ;; restored. 
    7575  (invoke-transient-init-functions)) 
    76  

  • trunk/projects/bos/m2/m2-pdf.lisp

    r3644 r3656  
    66                                            (with-output-to-string (s) 
    77                                              (apply #'geometry:format-lon-lat s coord))))) 
    8         (pdf:draw-left-text x y part font 8 300) 
    9         (incf y 10)))) 
     8      (pdf:draw-left-text x y part font 8 300) 
     9      (incf y 10)))) 
    1010 
    1111(defun make-m2-pdf (contract &key print) 

  • trunk/projects/bos/m2/m2-store.lisp

    r3537 r3656  
    1414  (setf (slot-value store 'tile-index) 
    1515        (indexed-class-index-named (find-class 'm2) 'm2-index))) 
    16  

  • trunk/projects/bos/m2/m2.lisp

    r3638 r3656  
    1  
    21(in-package :bos.m2) 
    32 
    4 ;;;  
     3;;; 
    54(defun get-map-tile (x y) 
    65  (get-tile (m2-store-tile-index *m2-store*) x y)) 
    …… 
    190189             (eq sponsor (contract-sponsor contract)))) 
    191190    (let ((consistent t)) 
    192       (unless (every #'contract-points-to-sponsor (sponsor-contracts sponsor))         
     191      (unless (every #'contract-points-to-sponsor (sponsor-contracts sponsor)) 
    193192        (let ((*print-length* 5)) 
    194193          (warn "~s of ~s dont point to it by CONTRACT-SPONSOR~ 
    …… 
    302301        (error "invalid contract id (wrong type) ~A" id))))) 
    303302 
    304 (defun publish-contract-change (contract &key type)     
     303(defun publish-contract-change (contract &key type) 
    305304  (publish-rect-change *rect-publisher* (contract-bounding-box contract) contract :type type)) 
    306305 
    …… 
    379378      (collect (list (m2-x m2) (m2-y m2)))))) 
    380379 
    381 (defun contracts-bounding-box (&optional (contracts (all-contracts)))   
     380(defun contracts-bounding-box (&optional (contracts (all-contracts))) 
    382381  (geometry:with-bounding-box-collect (collect) 
    383382    (dolist (contract contracts) 
    …… 
    461460      (dolist (m2 (contract-m2s contract) contracts) 
    462461        (let ((x (m2-x m2)) 
    463               (y (m2-y m2)))         
     462              (y (m2-y m2))) 
    464463          (push-neighbour (1- x) y) 
    465464          (push-neighbour x (1- y)) 
    …… 
    570569                                         #'eq))) 
    571570    (let ((consistent t)) 
    572       (unless (every #'m2-points-to-contract (contract-m2s contract))         
     571      (unless (every #'m2-points-to-contract (contract-m2s contract)) 
    573572        (let ((*print-length* 5)) 
    574573          (warn "~s of ~s dont point to it by M2-CONTRACT~ 
    …… 
    581580      (when (null (contract-m2s contract)) 
    582581        (warn "~s has no m2s" contract) 
    583         (setq consistent nil))       
     582        (setq consistent nil)) 
    584583      (when (not (contract-connected-p contract)) 
    585584        (warn "~s has m2s that are not connected" contract) 
    …… 
    650649        (values 0 0)))) 
    651650 
    652 (defun last-paid-contracts ()   
     651(defun last-paid-contracts () 
    653652  (remove-if (lambda (contract) 
    654653               (or (null contract) 
    …… 
    696695  (force-output) 
    697