[bknr-cvs] r1992 - in branches/xml-class-rework/projects/bos: m2 payment-website/infosystem payment-website/infosystem/de worldpay-test
bknr at bknr.net
bknr at bknr.net
Sat Oct 14 11:25:19 UTC 2006
Author: hhubner
Date: 2006-10-14 07:25:17 -0400 (Sat, 14 Oct 2006)
New Revision: 1992
Added:
branches/xml-class-rework/projects/bos/worldpay-test/contract-image-handler.lisp
Modified:
branches/xml-class-rework/projects/bos/m2/m2.lisp
branches/xml-class-rework/projects/bos/m2/packages.lisp
branches/xml-class-rework/projects/bos/payment-website/infosystem/de/satellitenkarte.htm
branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js
branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp
branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd
branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp
Log:
Improved rendering of sold areas. The rendering is now done on the server
side, which greatly improves performance with large contracts.
Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-14 09:35:08 UTC (rev 1991)
+++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-14 11:25:17 UTC (rev 1992)
@@ -158,6 +158,7 @@
;;; CONTRACT-PAIDP (contract) => boolean
;;; CONTRACT-DATE (contract) => Universal-Timestamp
;;; CONTRACT-M2S (contract) => list of m2
+;;; CONTRACT-BOUNDING-BOX (contract) => (list left top width height)
;;;
;;; CONTRACT-SET-PAIDP (contract newval) => newval
@@ -266,6 +267,15 @@
image-tiles))
image-tiles))
+(defmethod contract-bounding-box ((contract contract))
+ (let (min-x min-y max-x max-y)
+ (dolist (m2 (contract-m2s contract))
+ (setf min-x (min (m2-x m2) (or min-x (m2-x m2))))
+ (setf min-y (min (m2-y m2) (or min-y (m2-y m2))))
+ (setf max-x (max (m2-x m2) (or max-x (m2-x m2))))
+ (setf max-y (max (m2-y m2) (or max-y (m2-y m2)))))
+ (list min-x min-y (1+ (- max-x min-x)) (1+ (- max-y min-y)))))
+
(defun tx-make-contract (sponsor m2-count &key date paidp expires)
(warn "Old tx-make-contract transaction used, contract dates may be wrong")
(tx-do-make-contract sponsor m2-count :date date :paidp paidp :expires expires))
@@ -321,30 +331,19 @@
"Erzeugt das Quadratmeter-Javascript für die angegebenen Contracts"
(with-output-to-string (*standard-output*)
(let ((paid-contracts (remove nil (sponsor-contracts sponsor) :key #'contract-paidp)))
- (format t "profil = [];~%")
- (format t "qms = [ undefined ];~%")
+ (format t "profil = {};~%")
(format t "profil['id'] = ~D;~%" (store-object-id sponsor))
(format t "profil['name'] = ~S;~%" (string-safe (or (user-full-name sponsor) "[anonym]")))
(format t "profil['country'] = ~S;~%" (or (sponsor-country sponsor) "[unbekannt]"))
(format t "profil['anzahl'] = ~D;~%" (loop for contract in paid-contracts
sum (length (contract-m2s contract))))
(format t "profil['nachricht'] = '~A';~%" (string-safe (sponsor-info-text sponsor)))
+ (format t "profil['contracts'] = [ ];~%" (store-object-id (first paid-contracts)))
(loop for contract in paid-contracts
- for m2s = (sort (copy-list (contract-m2s contract)) #'(lambda (a b) (if (eql (m2-y a) (m2-y b))
- (< (m2-x a) (m2-x b))
- (< (m2-y a) (m2-y b)))))
- do (progn
- (format t "var qm = [];~%")
- (format t "qm['x'] = ~D;~%" (m2-x (first (contract-m2s contract))))
- (format t "qm['y'] = ~D;~%" (m2-y (first (contract-m2s contract))))
- (format t "qm['datum'] = ~S;~%" (format-date-time (contract-date contract) :show-time nil))
- (format t "qm['qm_x'] = [0, ~D~{,~D~}];~%"
- (m2-x (first m2s))
- (mapcar #'m2-x (cdr m2s)))
- (format t "qm['qm_y'] = [0, ~D~{,~D~}];~%"
- (m2-y (first m2s))
- (mapcar #'m2-y (cdr m2s)))
- (format t "qms.push(qm);~%"))))))
+ do (destructuring-bind (left top width height) (contract-bounding-box contract)
+ (format t "profil.contracts.push({ left: ~A, top: ~A, width: ~A, height: ~A, date: ~S });~%"
+ left top width height
+ (format-date-time (contract-date contract) :show-time nil)))))))
(defun delete-directory (pathname)
(when (probe-file pathname)
Modified: branches/xml-class-rework/projects/bos/m2/packages.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/packages.lisp 2006-10-14 09:35:08 UTC (rev 1991)
+++ branches/xml-class-rework/projects/bos/m2/packages.lisp 2006-10-14 11:25:17 UTC (rev 1992)
@@ -97,6 +97,7 @@
#:contract-paidp
#:contract-date
#:contract-m2s
+ #:contract-bounding-box
#:contract-color
#:contract-cert-issued
#:contract-set-paidp
Modified: branches/xml-class-rework/projects/bos/payment-website/infosystem/de/satellitenkarte.htm
===================================================================
--- branches/xml-class-rework/projects/bos/payment-website/infosystem/de/satellitenkarte.htm 2006-10-14 09:35:08 UTC (rev 1991)
+++ branches/xml-class-rework/projects/bos/payment-website/infosystem/de/satellitenkarte.htm 2006-10-14 11:25:17 UTC (rev 1992)
@@ -310,6 +310,9 @@
<div id="qmDetail" style="position:absolute; width:1px; height:1; z-index:4; left: 0px; top: 0px; visibility: hidden;">
<div id="qmDetailKarte" style="position:absolute; width:360px; height:390px; z-index:1; left: 169px; top: 100px; visibility: inherit;" class="KarteRahmen">
<div id="qmLupe" style="position:absolute; width:36px; height:24px; z-index:11; visibility: inherit;"><img src="../bilder/lupe.gif" width="36" height="24"/></div>
+ <div id="selected_contract" style="position:absolute; z-index:10; visibility: inherit;">
+ <img id="selected_contract_img" src="../bilder/spacer.gif" width="1" height="1"/>
+ </div>
<div id="LayersMenu" class="KarteRahmen" style="position: absolute; bottom: 31px; right: 1px; z-index: 15; visibility: inherit;">
<table width="90" border="0" cellspacing="0" cellpadding="0">
<tr>
Modified: branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js
===================================================================
--- branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js 2006-10-14 09:35:08 UTC (rev 1991)
+++ branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js 2006-10-14 11:25:17 UTC (rev 1992)
@@ -30,7 +30,6 @@
var qm = new Array; // Array in dem die Daten fuer die QM gespeichert werden
var uebersicht_icons = new Array; // Array in dem die Daten fuer die Icons der Übersichtskarte gespeichert werden
var profil = new Array; // Array in dem die Daten fuer das Profil gespeichert werden
-var n_qm = new Array; // Array in dem die Daten fuer das nachbar-Quadratmeter gespeichert werden
var n_profil = new Array; // Array in dem die Daten fuer das Nachbar-Profil gespeichert werden
var loginstatus = false; // Status ob Anwender eingeloggt sind wird ueber login_pruefen() gefuellt
@@ -351,12 +350,8 @@
n_profil['anzahl'] = 0;
n_profil['datum'] = "";
n_profil['nachricht'] = "";
- n_qm = [];
- n_qm[1] = false;
- n_qm[1] = false;
profil_variable = 'n_profil';
- qm_variable = 'n_qm';
m2complete = false;
window.frames['data'].window.location.replace(http_pfad + "/m2-javascript/" + fremd_x + "/" + fremd_y);
@@ -389,8 +384,8 @@
+ '</td></tr><tr> <td colspan="2" class="PoiNavigation"><img src="/infosystem/bilder/spacer.gif" width="1" height="10"/></td></tr>'
+ '<tr> <td width="60" class="PoiNavigation">' + msg('gesponsort') + ':</td><td class="PoiNavigation">'
+ n_profil['anzahl']
- + ' m²</td></tr><tr> <td width="60" class="PoiNavigation">' + msg('seit') + ':</td><td class="PoiNavigation">'
- + n_qm[1]['datum']
+ + ' m²</td></tr><tr> <td width="60" class="PoiNavigation">'
+ // + msg('seit') + ':</td><td class="PoiNavigation">' + 'XXX FIXME!' // n_qm[1]['datum']
+ '</td></tr><tr> <td colspan="2" class="PoiNavigation"><img src="/infosystem/bilder/spacer.gif" width="1" height="20"/></td></tr>'
+ '<tr> <td colspan="2" class="PoiNavigation">'
+ n_profil['nachricht']
@@ -398,7 +393,7 @@
}
// Inhalt der Ueberschrift und des Infotextes werden gesetzt
document.getElementById("qmLaden").style.visibility = "hidden";
- if (n_qm[1]) {
+ if (true) { // XXX FIXME!
document.getElementById("Ueberschrift").innerHTML = msg("Verkaufte m²");
} else {
document.getElementById("Ueberschrift").innerHTML = msg("zu verkaufen!");
@@ -418,51 +413,20 @@
}
function n_qm_erzeugen() {
- // Erzeugen der Nachbarquadratmeter
- // alte qm loeschen
- if (n_zeilen > 0) {
- for (var i = 1; i < n_zeilen; i++) {
- var loeschen = eval("document.getElementById('n_qm" + i + "')");
- document.getElementById("qmAusschnitt").removeChild(loeschen);
- }
- schreibe_debugger("<br/> -> " + n_zeilen + " zeilen geloescht");
- }
- // aktuelle qm einzeichnen
- n_zeilen = 1;
- objekt = n_qm[1];
+ // Erzeugen der Nachbarquadratmeter
+ var selected_contract_img = document.getElementById('selected_contract_img');
+ if (n_profil.contracts) {
+ var contract = n_profil.contracts[0];
- if (objekt['qm_x']) {
- schreibe_debugger("<br/> -> Es sollen " + objekt['qm_x'].length + " erzeugt werden");
- for (i=1; i < objekt['qm_x'].length; i++) {
-
- // neue Ebene erstellen, Ebene ist abhaengig von <Uebersicht>
- var neueebene=document.createElement("DIV");
- document.getElementById("qmAusschnitt").appendChild(neueebene);
-
- // Testen ob Icon links oder rechts steht --> Ebene muß um 150 px versetzt werden oder nicht
- var x = parseInt(Math.round(objekt['qm_x'][i] - x_anf) * 5);
- var y = parseInt(Math.round(objekt['qm_y'][i] - y_anf) * 5);
- var width=5;
- while (objekt['qm_y'][i] == objekt['qm_y'][(i + 1)]) {
- width += 5;
- i++;
- }
- // definieren der Styles
- neueebene.style.position="absolute";
- neueebene.style.left = x + "px";
- neueebene.style.top = y + "px";
- neueebene.style.height = "5px";
- neueebene.style.width = width + "px";
- neueebene.style.zIndex ="9";
- neueebene.style.visibility = "inherit";
- neueebene.id = "n_qm" + n_zeilen;
- neueebene.align = "left";
- neueebene.innerHTML = '<img src="/infosystem/bilder/gelb.gif" height="5" width="' + width + '"/>';
- n_zeilen++;
- }
+ selected_contract_img.src = '/contract-image/' + contract.id;
+ selected_contract_img.width = contract.width;
+ selected_contract_img.height = contract.height;
+
+ document.getElementById('selected_contract').style.left = (contract.left - x_anf) + 'px';
+ document.getElementById('selected_contract').style.top = (contract.top - y_anf) + 'px';
+ } else {
+ selected_contract_img.src = '../bilder/spacer.gif';
}
- schreibe_debugger("<br/> -> " + n_zeilen + " zeilen fuer die Nachbar-Quadratmeter erzeugt");
- return n_zeilen;
}
function qm_zusammenfassen() {
@@ -1096,16 +1060,6 @@
}
schreibe_debugger("<br/> -> " + erzeugte_zeilen + " zeilen geloescht");
- // fremde Quadratmeter löschen
- if (n_zeilen > 0) {
- for (var i = 1; i < n_zeilen; i++) {
- var loeschen = eval("document.getElementById('n_qm" + i + "')");
- document.getElementById("qmAusschnitt").removeChild(loeschen);
- }
- schreibe_debugger("<br/> -> " + n_zeilen + " zeilen geloescht");
- n_zeilen = 0;
- }
-
// qm loeschen
for (var i = 1; i <= erzeugte_positionen; i++) {
var loeschen = eval("document.getElementById('pos" + i + "')");
Added: branches/xml-class-rework/projects/bos/worldpay-test/contract-image-handler.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/contract-image-handler.lisp 2006-10-14 09:35:08 UTC (rev 1991)
+++ branches/xml-class-rework/projects/bos/worldpay-test/contract-image-handler.lisp 2006-10-14 11:25:17 UTC (rev 1992)
@@ -0,0 +1,30 @@
+
+(in-package :worldpay-test)
+
+(enable-interpol-syntax)
+
+(defclass contract-image-handler (object-handler)
+ ()
+ (:default-initargs :class 'contract))
+
+(defmethod handle-object ((handler contract-image-handler) contract req)
+ "Create and return a GD image of the contract. The returned
+rectangular image will have the size of the contracts' bounding box.
+All square meters will have yellow color, the background will be transparent."
+ (destructuring-bind (left top width height) (contract-bounding-box contract)
+ (cl-gd:with-image* (width height)
+ (setf (cl-gd:transparent-color) (cl-gd:allocate-color 0 0 0))
+ ;; 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 :initial-element 0))
+ (yellow (cl-gd:allocate-color 255 255 0)))
+ (flet ((set-pixel (x y)
+ (decf x left)
+ (decf y top)
+ (setf (aref work-array x y) yellow)))
+ (dolist (m2 (contract-m2s contract))
+ (set-pixel (m2-x m2) (m2-y m2))))
+ (cl-gd:do-rows (y)
+ (cl-gd:do-pixels-in-row (x)
+ (setf (cl-gd:raw-pixel) (aref work-array x y)))))
+ (emit-image-to-browser req cl-gd:*default-image* :png))))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-10-14 09:35:08 UTC (rev 1991)
+++ branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-10-14 11:25:17 UTC (rev 1992)
@@ -235,10 +235,10 @@
(with-http-body (req *ent*)
(let ((*standard-output* *html-stream*))
(princ "<script language=\"JavaScript\">") (terpri)
- (princ "var profil; var qms;") (terpri)
+ (princ "var profil;") (terpri)
(when (and sponsor (find-if #'contract-paidp (sponsor-contracts sponsor)))
(princ (make-m2-javascript sponsor)) (terpri))
- (princ "parent.qm_fertig(profil, qms);") (terpri)
+ (princ "parent.qm_fertig(profil);") (terpri)
(princ "</script>") (terpri)))))))
(defclass sponsor-login-handler (page-handler)
Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd 2006-10-14 09:35:08 UTC (rev 1991)
+++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd 2006-10-14 11:25:17 UTC (rev 1992)
@@ -28,6 +28,7 @@
(:file "poi-handlers" :depends-on ("web-utils"))
(:file "boi-handlers" :depends-on ("web-utils"))
(:file "contract-handlers" :depends-on ("web-utils"))
+ (:file "contract-image-handler" :depends-on ("web-utils"))
(:file "reports-xml-handler" :depends-on ("boi-handlers"))
(:file "sponsor-handlers" :depends-on ("web-utils"))
(:file "news-handlers" :depends-on ("web-utils"))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-14 09:35:08 UTC (rev 1991)
+++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-14 11:25:17 UTC (rev 1992)
@@ -197,6 +197,7 @@
("/create-allocation-area" create-allocation-area-handler)
("/allocation-area" allocation-area-handler)
("/allocation-area-gfx" allocation-area-gfx-handler)
+ ("/contract-image" contract-image-handler)
("/certificate" certificate-handler)
("/cert-regen" cert-regen-handler)
("/admin" admin-handler)
More information about the Bknr-cvs
mailing list