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

[BKNR Commits]

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

new macro do-countries and some bugfixes to contract-stats
U   trunk/projects/bos/m2/m2.lisp
U   trunk/projects/bos/m2/packages.lisp

Modified: trunk/projects/bos/m2/m2.lisp
===================================================================
--- trunk/projects/bos/m2/m2.lisp	2008-07-17 12:22:38 UTC (rev 3485)
+++ trunk/projects/bos/m2/m2.lisp	2008-07-17 12:50:50 UTC (rev 3486)
@@ -603,21 +603,23 @@
   (let* ((area (contract-area contract))
 	 (sponsor (contract-sponsor contract))
 	 (new-sponsor-p (alexandria:length= 1 (sponsor-contracts sponsor)))
-	 (country (string-upcase (sponsor-country sponsor))))
+         (%country (sponsor-country sponsor))
+	 (country (and %country (string-upcase %country))))
     (with-slots (sold-m2s paying-sponsors country-sponsors last-contracts)
-	*contract-stats*
+        *contract-stats*
       ;; sold-m2s
       (incf sold-m2s area)
       ;; paying-sponsors
       (when new-sponsor-p
-	(incf paying-sponsors))
+        (incf paying-sponsors))
       ;; country-sponsors
-      (let ((country-stat (gethash country country-sponsors)))
-	(unless country-stat
-	  (setq country-stat (setf (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))
+      (when country
+        (let ((country-stat (gethash country country-sponsors)))
+          (unless country-stat
+            (setq country-stat (setf (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))))
@@ -641,6 +643,17 @@
 		   (object-destroyed-p contract)))
 	     (contract-stats-last-contracts *contract-stats*)))
 
+(defun invoke-with-countries (function as-keyword)
+  (alexandria:maphash-keys
+   (if as-keyword
+       (lambda (country) (funcall function (make-keyword-from-string country)))
+       function)
+   (contract-stats-country-sponsors *contract-stats*)))
+
+(defmacro do-countries ((country &key as-keyword) &body body)
+  (check-type country symbol)
+  `(invoke-with-countries (lambda (,country) , at body) ,as-keyword))
+
 (register-store-transient-init-function 'initialize-contract-stats)
 
 (defun string-safe (string)

Modified: trunk/projects/bos/m2/packages.lisp
===================================================================
--- trunk/projects/bos/m2/packages.lisp	2008-07-17 12:22:38 UTC (rev 3485)
+++ trunk/projects/bos/m2/packages.lisp	2008-07-17 12:50:50 UTC (rev 3486)
@@ -170,6 +170,7 @@
 	   #:number-of-paying-sponsors
 	   #:contract-stats-for-country
 	   #:last-paid-contracts
+           #:do-countries
 	   	   	   
 	   #:make-m2-javascript
            #:recolorize-contracts