[bknr-cvs] ksprotte changed trunk/projects/bos/m2/

[BKNR Commits]

Revision: 3479
Author: ksprotte
URL: http://bknr.net/trac/changeset/3479

added new cache contract-stats that allows for last-paid-contracts, but also new queries
U   trunk/projects/bos/m2/m2.lisp
U   trunk/projects/bos/m2/packages.lisp
U   trunk/projects/bos/m2/poi.lisp

Modified: trunk/projects/bos/m2/m2.lisp
===================================================================
--- trunk/projects/bos/m2/m2.lisp	2008-07-17 09:08:08 UTC (rev 3478)
+++ trunk/projects/bos/m2/m2.lisp	2008-07-17 11:42:34 UTC (rev 3479)
@@ -295,7 +295,7 @@
 (deftransaction contract-set-paidp (contract newval)
   (setf (contract-paidp contract) newval)
   (publish-contract-change contract)
-  (add-to-last-contracts-cache contract)
+  (add-to-contract-stats contract)
   (bknr.rss::add-item "news" contract))
 
 (defmethod contract-price ((contract contract))
@@ -580,28 +580,67 @@
   ;; use only CONTRACT-PAIDP, but mean CONTRACT-PUBLISHED-P
   (contract-paidp contract))
 
-(defvar *last-contracts-cache* nil)
+;;; contract-stats
 (defconstant +last-contracts-cache-size+ 20)
+(defvar *contract-stats*)
 
-(defun last-paid-contracts ()
-  (unless *last-contracts-cache*
-    (setf *last-contracts-cache* (subseq (append (sort (remove-if-not #'contract-paidp (class-instances 'contract))
-						       #'> :key #'contract-date)
-						 (make-list +last-contracts-cache-size+))
-					 0 +last-contracts-cache-size+)))
-  (remove-if #'object-destroyed-p *last-contracts-cache*))
+(defstruct country-stat
+  (sold-m2s 0)
+  (paying-sponsors 0))
 
-(defun add-to-last-contracts-cache (contract)
-  (last-paid-contracts) ; force cache initialization, should really be done by a eval-when
-  (push contract *last-contracts-cache*)
-  (setf (cdr (nthcdr (1- +last-contracts-cache-size+) *last-contracts-cache*)) nil))
+(defstruct contract-stats
+  (sold-m2s 0)
+  (paying-sponsors 0)
+  (country-sponsors (make-hash-table :test #'equal))
+  (last-contracts (make-list +last-contracts-cache-size+)))
 
+(defun initialize-contract-stats ()
+  (setq *contract-stats* (make-contract-stats))
+  (dolist (contract (class-instances 'contract))
+    (add-to-contract-stats contract)))
+
+(defun add-to-contract-stats (contract)
+  (let* ((area (contract-area contract))
+	 (sponsor (contract-sponsor contract))
+	 (new-sponsor-p (alexandria:length= 1 (sponsor-contracts sponsor)))
+	 (country (string-upcase (sponsor-country sponsor))))
+    (with-slots (sold-m2s paying-sponsors country-sponsors last-contracts)
+	*contract-stats*
+      ;; sold-m2s
+      (incf sold-m2s area)
+      ;; paying-sponsors
+      (when new-sponsor-p
+	(incf paying-sponsors))
+      ;; country-sponsors
+      (let ((country-stat (gethash country country-sponsors (make-country-stat))))
+	(when new-sponsor-p
+	  (incf (country-stat-paying-sponsors country-stat)))
+	(incf (country-stat-sold-m2s country-stat) area))
+      ;; last-contracts
+      (setf last-contracts (nbutlast last-contracts))
+      (push contract last-contracts))))
+
 (defun number-of-sold-sqm ()
-  (let ((retval 0))
-    (dolist (contract (remove-if-not #'contract-paidp (class-instances 'contract)))
-      (incf retval (length (contract-m2s contract))))
-    retval))
+  (contract-stats-sold-m2s *contract-stats*))
 
+(defun paying-sponsors ()
+  (contract-stats-paying-sponsors *contract-stats*))
+
+(defun contract-stats-for-country (country)
+  (let ((stat (gethash country (contract-stats-country-sponsors *contract-stats*))))
+    (if stat
+	(values (country-stat-paying-sponsors stat)
+		(country-stat-sold-m2s stat))
+	(values 0 0))))
+
+(defun last-paid-contracts ()  
+  (remove-if (lambda (contract)
+	       (or (null contract)
+		   (object-destroyed-p contract)))
+	     (contract-stats-last-contracts *contract-stats*)))
+
+(register-store-transient-init-function 'initialize-contract-stats)
+
 (defun string-safe (string)
   (if string
       (escape-nl (arnesi:escape-as-html string))

Modified: trunk/projects/bos/m2/packages.lisp
===================================================================
--- trunk/projects/bos/m2/packages.lisp	2008-07-17 09:08:08 UTC (rev 3478)
+++ trunk/projects/bos/m2/packages.lisp	2008-07-17 11:42:34 UTC (rev 3479)
@@ -165,8 +165,13 @@
 	   #:contract-pdf-pathname
 	   #:contract-pdf-url
 	   #:contract-download-only-p
+	   ;; contract-stats
+	   #:number-of-sold-sqm
+	   #:paying-sponsors
+	   #:contract-stats-for-country
+	   #:last-paid-contracts
+	   	   	   
 	   #:make-m2-javascript
-	   #:last-paid-contracts
            #:recolorize-contracts
            #:contracts-well-colored-p
            #:contract-published-p

Modified: trunk/projects/bos/m2/poi.lisp
===================================================================
--- trunk/projects/bos/m2/poi.lisp	2008-07-17 09:08:08 UTC (rev 3478)
+++ trunk/projects/bos/m2/poi.lisp	2008-07-17 11:42:34 UTC (rev 3479)
@@ -127,8 +127,8 @@
 (defun make-poi-javascript (language)
   "Erzeugt das POI-Javascript für das Infosystem"
   (with-output-to-string (*standard-output*)
-    (format t "var anzahlSponsoren = ~D;~%" (length (remove-if-not #'(lambda (sponsor) (some #'contract-paidp (sponsor-contracts sponsor)))
-							       (class-instances 'sponsor))))
+    (format t "var anzahlSponsoren = ~D;~%" (count-if (lambda (sponsor) (some #'contract-paidp (sponsor-contracts sponsor)))
+						      (class-instances 'sponsor)))
     (format t "var anzahlVerkauft = ~D;~%" (bos.m2::number-of-sold-sqm))
     (format t "var pois = new Array;~%")
     (dolist (poi (sort (remove-if #'(lambda (poi) (or (not (poi-complete poi language))