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)