October 2006 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r1998 - branches/xml-class-rework/projects/bos/worldpay-test
by bknr＠bknr.net 15 Oct '06

15 Oct '06

Author: hhubner Date: 2006-10-15 09:28:08 -0400 (Sun, 15 Oct 2006) New Revision: 1998 Modified: branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp Log: Display country in sponsor table 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-15 11:06:10 UTC (rev 1997) +++ branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-10-15 13:28:08 UTC (rev 1998) @@ -31,7 +31,7 @@ (setf count (parse-integer count))) (with-bos-cms-page (req :title "Sponsor search results") ((:table :border "1") - (:tr (:th "ID") (:th "Date") (:th "Email") (:th "Name") (:th "SQM") (:th "Cert-Type") (:th "Paid by")) + (:tr (:th "ID") (:th "Date") (:th "Email") (:th "Name") (:th "SQM") (:th "Country") (:th "Cert-Type") (:th "Paid by")) (dolist (sponsor (sort (remove-if-not #'sponsor-contracts (class-instances 'sponsor)) #'> :key #'(lambda (sponsor) (contract-date (first (sponsor-contracts sponsor)))))) (when (or count @@ -43,6 +43,7 @@ (:td (:princ-safe (or (user-email sponsor) "<unknown>"))) (:td (:princ-safe (or (user-full-name sponsor) "<unknown>"))) (:td (:princ-safe (length (contract-m2s contract)))) + (:td (:princ-safe (sponsor-country sponsor))) (:td (:princ-safe (if (contract-download-only-p contract) "Download" "Print"))) (:td (:princ-safe (contract-paidp contract)))))) (when (eql (incf found) count)

1 0

[bknr-cvs] r1997 - branches/xml-class-rework/projects/bos/payment-website/templates/en
by bknr＠bknr.net 15 Oct '06

15 Oct '06

Author: hhubner Date: 2006-10-15 07:06:10 -0400 (Sun, 15 Oct 2006) New Revision: 1997 Modified: branches/xml-class-rework/projects/bos/payment-website/templates/en/headline3.xml branches/xml-class-rework/projects/bos/payment-website/templates/en/idea.xml branches/xml-class-rework/projects/bos/payment-website/templates/en/index.xml Log: orang-utan => orangutan Modified: branches/xml-class-rework/projects/bos/payment-website/templates/en/headline3.xml =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/templates/en/headline3.xml 2006-10-15 09:13:29 UTC (rev 1996) +++ branches/xml-class-rework/projects/bos/payment-website/templates/en/headline3.xml 2006-10-15 11:06:10 UTC (rev 1997) @@ -41,7 +41,7 @@ Nowadays, orangutans live only on Sumatra and Borneo. Massive rainforest destruction and unscrupulous pet trade could mean the end of their species. Malaysian bears are also in danger of losing their natural habitat. The nature reserve Samboja Lestari represents the last refuge for several animals - a last chance for their survival. Malaysian bears are already living in the reserve, in - a specially set aside area. In a few years time also orang-utans will be able to live there in freedom. + a specially set aside area. In a few years time also orangutans will be able to live there in freedom. <br /><br /> Rare species such as the Rhinoceros bird, the dwarf deer and the king cobra can already be observed in Samboja Lestari nowadays. </td> Modified: branches/xml-class-rework/projects/bos/payment-website/templates/en/idea.xml =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/templates/en/idea.xml 2006-10-15 09:13:29 UTC (rev 1996) +++ branches/xml-class-rework/projects/bos/payment-website/templates/en/idea.xml 2006-10-15 11:06:10 UTC (rev 1997) @@ -34,7 +34,7 @@ <tr><td height="6"></td></tr> <tr> <td colspan="3"> - By means of a unique reforestation concept BOS is creating a sanctuary for orang-utans, sunbears and other endangered species on Borneo -maybe the last one. + By means of a unique reforestation concept BOS is creating a sanctuary for orangutans, sunbears and other endangered species on Borneo -maybe the last one. Satellite pictures here on the internet make it possible to observe the progress of this concept. <br /><br /> During the last decades the once species-rich rainforest of @@ -43,7 +43,7 @@ </a> was cleared and burnt down relentlessly. Nutrient-consuming elephant grass took over completely. What remained was an ecological waste land. -Nowadays it is already visible that this doesn't have to stay - since 2001 BOS is creating new rainforest. An innovative concept of reforestation and protection is changing this area of over 16 mio sqm into a natural habitat again. In tropical Borneo plants grow much faster than in Europe. Already within a few years the first orang-utans can be released to share their freedom with other animals A nature reserve is being created for the permanent use of humans, animals and plants in Samboja Lestari ("eternal Samboja"). +Nowadays it is already visible that this doesn't have to stay - since 2001 BOS is creating new rainforest. An innovative concept of reforestation and protection is changing this area of over 16 mio sqm into a natural habitat again. In tropical Borneo plants grow much faster than in Europe. Already within a few years the first orangutans can be released to share their freedom with other animals A nature reserve is being created for the permanent use of humans, animals and plants in Samboja Lestari ("eternal Samboja"). </td> <td></td> </tr> Modified: branches/xml-class-rework/projects/bos/payment-website/templates/en/index.xml =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/templates/en/index.xml 2006-10-15 09:13:29 UTC (rev 1996) +++ branches/xml-class-rework/projects/bos/payment-website/templates/en/index.xml 2006-10-15 11:06:10 UTC (rev 1997) @@ -33,7 +33,7 @@ <tr><td height="6"></td></tr> <tr> <td colspan="3"> -By means of a unique reforestation concept BOS is creating a sanctuary for orang-utans, sunbears and other endangered species on Borneo -maybe the last one. Satellite pictures here on the internet make it possible to observe the progress of this concept. +By means of a unique reforestation concept BOS is creating a sanctuary for orangutans, sunbears and other endangered species on Borneo -maybe the last one. Satellite pictures here on the internet make it possible to observe the progress of this concept. <br /> <a href="idea" class="more"> ... more

1 0

[bknr-cvs] r1996 - branches/xml-class-rework/projects/bos/payment-website/infosystem
by bknr＠bknr.net 15 Oct '06

15 Oct '06

Author: hhubner Date: 2006-10-15 05:13:29 -0400 (Sun, 15 Oct 2006) New Revision: 1996 Modified: branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js Log: Clipping corrected. 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-15 08:58:32 UTC (rev 1995) +++ branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js 2006-10-15 09:13:29 UTC (rev 1996) @@ -426,17 +426,14 @@ image.width = contract.width * factor; image.height = contract.height * factor; - // falls der Vertrag aus dem angezeigten Bereich herausragt, wird das bild entsprechend geclipped. - // XXX fixme das ist noch nicht "ganz" fertig hier *hüstel* - if ((contract.left + contract.width - x_anf) > 360) { - container.style.clip - = 'rect(0px ' - + (contract.width - (contract.left + contract.width - x_anf - 360)) * factor + 'px ' - + (contract.height - (contract.top + contract.height - y_anf - 360)) * factor + 'px ' - + '0px)'; - } else { - container.style.clip = 'rect(auto auto auto auto)'; - } + // Falls der Vertrag aus dem angezeigten Bereich herausragt, wird das bild entsprechend geclipped. + container.style.clip + = 'rect(' + + Math.max(0, y_anf - contract.top) * factor + 'px ' + + Math.min(contract.width, contract.width - (contract.left + contract.width - x_anf - 360)) * factor + 'px ' + + Math.min(contract.height, contract.height - (contract.top + contract.height - y_anf - 360)) * factor + 'px ' + + Math.max(0, x_anf - contract.left) * factor + 'px' + + ')'; container.style.left = (contract.left - x_anf) * factor + 'px'; container.style.top = (contract.top - y_anf) * factor + 'px';

1 0

[bknr-cvs] r1995 - in branches/xml-class-rework/projects/bos: . payment-website/infosystem payment-website/infosystem/de payment-website/infosystem/en worldpay-test
by bknr＠bknr.net 15 Oct '06

15 Oct '06

Author: hhubner Date: 2006-10-15 04:58:32 -0400 (Sun, 15 Oct 2006) New Revision: 1995 Modified: branches/xml-class-rework/projects/bos/build.lisp branches/xml-class-rework/projects/bos/payment-website/infosystem/de/satellitenkarte.htm branches/xml-class-rework/projects/bos/payment-website/infosystem/en/satellitenkarte.htm branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js branches/xml-class-rework/projects/bos/worldpay-test/contract-image-handler.lisp branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp Log: Contract clipping fixed for IE, not yet finished though. Modified: branches/xml-class-rework/projects/bos/build.lisp =================================================================== --- branches/xml-class-rework/projects/bos/build.lisp 2006-10-14 13:23:45 UTC (rev 1994) +++ branches/xml-class-rework/projects/bos/build.lisp 2006-10-15 08:58:32 UTC (rev 1995) @@ -51,6 +51,7 @@ (defun init () (fix-dpd) + (asdf:oos 'asdf:load-op :bos.web) (format t "BOS Online-System~%") (when *cert-daemon* (format t "; starting certificate generation daemon, slime and webserver not started~%") 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 13:23:45 UTC (rev 1994) +++ branches/xml-class-rework/projects/bos/payment-website/infosystem/de/satellitenkarte.htm 2006-10-15 08:58:32 UTC (rev 1995) @@ -5,6 +5,7 @@ <head> <title>Satellitenkarte - Samboja Lestari</title> <meta http-equiv="Content-Type" content="text/html; charset=utf-8" charset="utf-8" /> + <meta http-equiv="imagetoolbar" content="no"/> <link href="../satellitenkarte_style.css" rel="stylesheet"/> <script language="JavaScript" type="text/JavaScript" src="messages.js"></script> @@ -313,6 +314,9 @@ <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="own_contract" style="position:absolute; z-index:10; visibility: inherit;"> + <img id="own_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> @@ -401,6 +405,12 @@ "verkaufte" m² </div> <div id="qmAusschnitt" style="position:absolute; width:200px; height:115px; z-index:7; left: 172px; top: 512px; visibility: inherit;"> + <div id="lupe_selected_contract" style="position:absolute; z-index:10; visibility: inherit;"> + <img id="lupe_selected_contract_img" src="../bilder/spacer.gif" width="1" height="1"/> + </div> + <div id="lupe_own_contract" style="position:absolute; z-index:10; visibility: inherit;"> + <img id="lupe_own_contract_img" src="../bilder/spacer.gif" width="1" height="1"/> + </div> <table width="1800" height="1800" border="0" cellpadding="0" cellspacing="0"> <tr> <td><img name="qmlupe11" width="450" height="450" id="qmlupe11"/></td> Modified: branches/xml-class-rework/projects/bos/payment-website/infosystem/en/satellitenkarte.htm =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/infosystem/en/satellitenkarte.htm 2006-10-14 13:23:45 UTC (rev 1994) +++ branches/xml-class-rework/projects/bos/payment-website/infosystem/en/satellitenkarte.htm 2006-10-15 08:58:32 UTC (rev 1995) @@ -5,6 +5,7 @@ <head> <title>Satellite View - Samboja Lestari</title> <meta http-equiv="Content-Type" content="text/html; charset=utf-8" charset="utf-8" /> + <meta http-equiv="imagetoolbar" content="no"/> <link href="../satellitenkarte_style.css" rel="stylesheet"/> <script language="JavaScript" type="text/JavaScript" src="messages.js"></script> @@ -304,6 +305,12 @@ <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="own_contract" style="position:absolute; z-index:10; visibility: inherit;"> + <img id="own_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> @@ -392,6 +399,12 @@ "sold" m² </div> <div id="qmAusschnitt" style="position:absolute; width:200px; height:115px; z-index:7; left: 172px; top: 512px; visibility: inherit;"> + <div id="lupe_selected_contract" style="position:absolute; z-index:10; visibility: inherit;"> + <img id="lupe_selected_contract_img" src="../bilder/spacer.gif" width="1" height="1"/> + </div> + <div id="lupe_own_contract" style="position:absolute; z-index:10; visibility: inherit;"> + <img id="lupe_own_contract_img" src="../bilder/spacer.gif" width="1" height="1"/> + </div> <table width="1800" height="1800" border="0" cellpadding="0" cellspacing="0"> <tr> <td><img name="qmlupe11" width="450" height="450" id="qmlupe11"/></td> 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 13:23:45 UTC (rev 1994) +++ branches/xml-class-rework/projects/bos/payment-website/infosystem/javascript.js 2006-10-15 08:58:32 UTC (rev 1995) @@ -1,11 +1,14 @@ // JavaScript Document -*- Java -*- +// Originally written by Matthias, Systemtakt neue Medien GbR +// This program needs a lot of refactoring. + // XXX bei klick auf übersichtskarte bleiben die links der poi-thumbnails aktiv // XXX beim schliessen des opener-fensters funktioniert "m2 kaufen" nicht mehr // Debugger anzeigen? -var show_debugger = false; +var show_debugger = true; // var http_pfad = "http:// createrainforest.org:8080"; var http_pfad = ""; @@ -77,7 +80,7 @@ } } -function schreibe_debugger(text) { +function dbg(text) { // Schriebt einen Text in die Debugger-Ebene debugger_text = debugger_text + text; document.getElementById("debugger").innerHTML = debugger_text; @@ -132,7 +135,7 @@ close(); } - schreibe_debugger("<br/> init() <br/>"); + dbg("<br/> init() <br/>"); // initialisierung startet die Ladefuntkionen // parst den URL-String und trennt logout, sponsorid und passwort // Debugger anzeigen oder ausblenden @@ -153,7 +156,7 @@ timer = 0; - schreibe_debugger("<br/> -> lade POI"); + dbg("<br/> -> lade POI"); poicomplete = false; window.frames['data'].window.location.replace(http_pfad + "/poi-javascript"); poi_warten(); // starten der Wartenfunktion @@ -179,7 +182,7 @@ // poicomplet ist dei letzte Variable im Script daher wenn sie gesetzt ist ist das Ende erreicht if (poicomplete) { // wenn der Datensatz komplett geladen ist wird der timer auf Null gesetzt und je nachdem ob sich eingeloggt wurde oder nicht die loginueberpruefung oder die Punkterzeugung gestartet - schreibe_debugger("<br/> -> <b>POI geladen! login: " + login + "</b>"); + dbg("<br/> -> <b>POI geladen! login: " + login + "</b>"); document.getElementById("Info3Text").innerHTML = '<b>' + msg('Anzahl Sponsoren') + '</b><br />' + anzahlSponsoren + '<br /><br /><b>' + msg('Anzahl verkaufte m²') + '</b><br />' @@ -189,14 +192,16 @@ } UebersichtNavi(); qm_zusammenfassen(); + icon_versatz(); + poi_faehnchen_erzeugen(); } else { // wenn der Datensatz noch nicht komplett geladen ist wird der timer eroeht und die Funktion nochmal gestartet timer++; if (timer < 100) { - schreibe_debugger("."); + dbg("."); setTimeout("poi_warten()", 100); } else { - schreibe_debugger("<br/> -> <b>POI konnten nicht geladen werden</b>"); + dbg("<br/> -> <b>POI konnten nicht geladen werden</b>"); alert(msg('Fehler beim Laden der POI-Informationen, bitte probieren Sie es später noch einmal')); } } @@ -229,7 +234,7 @@ loginstatus = undefined; window.frames['data'].window.location.replace(url); - schreibe_debugger("<br/> -> lade Login-Status - url ist " + url + '<br/>'); + dbg("<br/> -> lade Login-Status - url ist " + url + '<br/>'); login_warten(); // Wartefunktion starten @@ -246,23 +251,23 @@ // wenn loginstatus gesetzt ist ist das Ende erreicht if (loginstatus) { - schreibe_debugger("<br/> -> <b>Login-Status geladen: " + loginstatus + "</b>"); + dbg("<br/> -> <b>Login-Status geladen: " + loginstatus + "</b>"); // wenn loginstatus gesetzt ist wir timer auf Null gesetzt // wenn lohinstatus = "login-failed" ist wird eine Fehlermeldung eingeblendet if (loginstatus == "not-logged-in") { - schreibe_debugger("<br/> -> <b>nicht eingeloggt!</b>"); + dbg("<br/> -> <b>nicht eingeloggt!</b>"); } if (loginstatus == "login-failed") { document.getElementById("Loginfehler").style.visibility = 'visible'; - schreibe_debugger("<br/> -> <b>Login fehlgeschlagen!</b>"); + dbg("<br/> -> <b>Login fehlgeschlagen!</b>"); } // wenn lohinstatus = "logged-in" ist wird das Anmeldefeld ausgelendet, das Logoutfeld eingeblendet und die Sponsorid angezeigt // danach werden die Punkte erzuegt und die Quadratmeter geladen if (loginstatus == "logged-in") { document.getElementById("Anmelden").style.visibility = "hidden"; document.getElementById("SponsorInfo").style.visibility = "visible"; - schreibe_debugger("<br/> -> <b>Login erfolgreich!</b>"); + dbg("<br/> -> <b>Login erfolgreich!</b>"); } else { document.getElementById("Anmelden").style.visibility = "visible"; document.getElementById("SponsorInfo").style.visibility = "hidden"; @@ -273,10 +278,10 @@ // wenn der Datensatz noch nicht komplett geladen ist wird der timer eroeht und die Funktion nochmal gestartet timer++; if (timer < 100) { - schreibe_debugger("."); + dbg("."); setTimeout("login_warten()", 100); } else { - schreibe_debugger("<br/> -> <b>Loginstatus konnten nicht geladen werden</b>"); + dbg("<br/> -> <b>Loginstatus konnten nicht geladen werden</b>"); } } return true; @@ -285,7 +290,7 @@ function ausloggen() { // Seesion loeschen -> ausloggen window.frames['data'].window.location.replace(http_pfad + "/logout"); - schreibe_debugger("<br/> -> ausloggen"); + dbg("<br/> -> ausloggen"); qm_laden(); return true; } @@ -296,12 +301,11 @@ timer = 0; profil_variable = 'profil'; - qm_variable = 'qm'; m2complete = false; window.frames['data'].window.location.replace(http_pfad + "/m2-javascript/"); - schreibe_debugger("<br/> -> lade Quadratmeter "); + dbg("<br/> -> lade Quadratmeter "); qm_warten(); // Wartefunktion starten return true; } @@ -310,29 +314,26 @@ // Wartefunktion, da das Laden etwas traege ist wartet dieses Script bis derf Datensatz komplatt geladen ist // m2complete ist die letzte Variable im Script daher wenn sie gesetzt ist ist das Ende erreicht if (m2complete) { - // wenn m2complete gelden ist wird qm_erzeugen() gestartet und der timer auf Null gesetzt - schreibe_debugger("<br/> -> <b>Quadratmeter geladen!</b>"); + dbg("<br/> -> <b>Quadratmeter geladen!</b>"); poi_laden(); } else { // wenn der Datensatz noch nicht komplett geladen ist wird der timer eroeht und die Funktion nochmal gestartet timer++; if (timer < 100) { - schreibe_debugger("."); + dbg("."); setTimeout("qm_warten()", 100); } else { - schreibe_debugger("<br/> -> <b>qm konnten nicht geladen werden</b>"); + dbg("<br/> -> <b>qm konnten nicht geladen werden</b>"); } } return true; } var profil_variable; -var qm_variable; -function qm_fertig(_profil, _qms) { +function qm_fertig(_profil) { if (_profil) { eval(profil_variable + " = _profil;"); - eval(qm_variable + " = _qms;"); } m2complete = true; } @@ -344,19 +345,16 @@ // der Datensatz wird vorher auf Nullwerte gesetzt damit fals keine Daten in der URL enthalten sind der Quadratmeter als unverkauft angezeigt wird m2complete = false; timer=0; - n_profil = []; - n_profil['name'] = msg("noch nicht verkauft"); - n_profil['country'] = ""; - n_profil['anzahl'] = 0; - n_profil['datum'] = ""; - n_profil['nachricht'] = ""; + n_profil = { + name: msg("noch nicht verkauft") + }; profil_variable = 'n_profil'; m2complete = false; window.frames['data'].window.location.replace(http_pfad + "/m2-javascript/" + fremd_x + "/" + fremd_y); n_qm_warten(); // Wartefunktion starten - schreibe_debugger("<br/> -> lade Nachbar-Quadratmeter (" + fremd_x + "/" + fremd_y + ")"); + dbg("<br/> -> lade Nachbar-Quadratmeter (" + fremd_x + "/" + fremd_y + ")"); return true; } @@ -364,9 +362,9 @@ // Wartefunktion, da das Laden etwas traege ist wartet dieses Script bis derf Datensatz komplatt geladen ist // m2complete ist die letzte Variable im Script daher wenn sie gesetzt ist ist das Ende erreicht if (m2complete) { - // timer wird auf Nullgesetzt und n_qm_erzeugen wird gestartet + // timer wird auf Nullgesetzt und display_selected_contract wird gestartet timer = 0; - schreibe_debugger("<br/> -> <b>Nachbar-Quadratmeter geladen!</b>"); + dbg("<br/> -> <b>Nachbar-Quadratmeter geladen!</b>"); // text fuer das Nachbarprofil wird zusammengesetzt if (n_profil['name'] == msg("noch nicht verkauft")) { var text = '<table width="155" border="0" cellspacing="0" cellpadding="0"><tr><td colspan="2" class="PoiNavigation">' @@ -385,7 +383,7 @@ + '<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">' + 'XXX FIXME!' // n_qm[1]['datum'] + + msg('seit') + ':</td><td class="PoiNavigation">' + n_profil.contracts[0].date + '</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'] @@ -393,46 +391,93 @@ } // Inhalt der Ueberschrift und des Infotextes werden gesetzt document.getElementById("qmLaden").style.visibility = "hidden"; - if (true) { // XXX FIXME! + if (n_profil.contracts) { document.getElementById("Ueberschrift").innerHTML = msg("Verkaufte m²"); } else { document.getElementById("Ueberschrift").innerHTML = msg("zu verkaufen!"); } document.getElementById("qmInfoText").innerHTML = text; - n_qm_erzeugen(); + display_selected_contract(); } else { // wenn der Datensatz noch nicht komplett geladen ist wird der timer eroeht und die Funktion nochmal gestartet timer++; if (timer < 100) { setTimeout("n_qm_warten()", 100); } else { - document.getElementById("qmLaden").style.visibility = "hidden"; schreibe_debugger("<br/> -> <b>Nachbar-Quadratmeter konnten nicht geladen werden</b>"); + document.getElementById("qmLaden").style.visibility = "hidden"; dbg("<br/> -> <b>Nachbar-Quadratmeter konnten nicht geladen werden</b>"); } } return true; } -function n_qm_erzeugen() { - // Erzeugen der Nachbarquadratmeter - var selected_contract_img = document.getElementById('selected_contract_img'); +function load_contract_image(contract, image, factor, color) +{ + var container = image.parentNode; + + if (!color) { + color = 'ffff00'; + } + + container.style.visibility = 'hidden'; + image.onload = function () { + this.parentNode.style.visibility = 'inherit'; + } + image.src = '/contract-image/' + contract.id + '/' + color; + image.width = contract.width * factor; + image.height = contract.height * factor; + + // falls der Vertrag aus dem angezeigten Bereich herausragt, wird das bild entsprechend geclipped. + // XXX fixme das ist noch nicht "ganz" fertig hier *hüstel* + if ((contract.left + contract.width - x_anf) > 360) { + container.style.clip + = 'rect(0px ' + + (contract.width - (contract.left + contract.width - x_anf - 360)) * factor + 'px ' + + (contract.height - (contract.top + contract.height - y_anf - 360)) * factor + 'px ' + + '0px)'; + } else { + container.style.clip = 'rect(auto auto auto auto)'; + } + + container.style.left = (contract.left - x_anf) * factor + 'px'; + container.style.top = (contract.top - y_anf) * factor + 'px'; + +} + +function display_selected_contract() +{ + // Anzeigen der ausgewählten Nachbarquadratmeter + if (n_profil.contracts) { var contract = n_profil.contracts[0]; - 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'; + load_contract_image(contract, + document.getElementById('selected_contract_img'), + 1); + load_contract_image(contract, + document.getElementById('lupe_selected_contract_img'), + 5); } else { - selected_contract_img.src = '../bilder/spacer.gif'; + document.getElementById('selected_contract_img').src = '../bilder/spacer.gif'; + document.getElementById('lupe_selected_contract_img').src = '../bilder/spacer.gif'; } } +function display_own_sqm() +{ + var contract = profil.contracts[0]; + var img = document.getElementById('own_contract_img'); + var enlarged_image = document.getElementById('lupe_own_contract_img'); + + load_contract_image(contract, img, 1, "ff0000"); + load_contract_image(contract, enlarged_image, 5, "ff0000"); +} + function qm_zusammenfassen() { // zusammenfassen mehererer Quadratmeterf�hnchen zu einem F�hnchen. - // es wird gepr�ft, ob sich auf der Detailkarte des qm noch mehr qm azeigen lassen dadurch wird die Darstellung der F�hnchen vereinfacht + // es wird gepr�ft, ob sich auf der Detailkarte des qm noch mehr qm anzeigen lassen dadurch wird die Darstellung der F�hnchen vereinfacht + return; + var i=1; while (qm[i]) { var qmV = qm[i]; @@ -471,7 +516,6 @@ } i++; } - icon_versatz(); return true; } @@ -532,20 +576,14 @@ index++; i++; } - var i=1; - while (qm[i]) { - if (qm[i]['status'] == "mitte") { - var qmV = qm[i]; - var uebV = uebersicht_icons[index]; - uebersicht_icons[index] = new Array; - uebersicht_icons[index]['x'] = qmV['x']; - uebersicht_icons[index]['y'] = qmV['y']; - uebersicht_icons[index]['icon'] = "qm"; - uebersicht_icons[index]['name'] = msg("meine m²"); - uebersicht_icons[index]['id'] = i; - } - index++; - i++; + if (profil.contracts) { + var contract = profil.contracts[0]; + uebersicht_icons[index++] = { + x: contract.left, + y: contract.top, + icon: 'qm', + name: msg("meine m²") + }; } var i=1; @@ -556,7 +594,7 @@ var vergleichV_x = uebersicht_icons[j]['x'] + 240; var vergleichV_y = uebersicht_icons[j]['y'] + 240; versatz = kollisonsabfrage(uebV_x + 240, uebV_y + 240, vergleichV_x, vergleichV_y); - // if (versatz[0]) {schreibe_debugger("<br/> -> POI[" + i + "] Richtungsaenderungvorschlag: " + versatz[0]);} + // if (versatz[0]) {dbg("<br/> -> POI[" + i + "] Richtungsaenderungvorschlag: " + versatz[0]);} var test = new Array; test[0] = versatz[0]; var versatz_index = versatz[0] + 1; @@ -567,7 +605,7 @@ versatz_index--; if (versatz_index < 1) {versatz_index = 4;} k++; - // schreibe_debugger("<br/> -> Richtungsaenderungstest bei " + versatz_index + " Fehler: " + richtungsfehler); + // dbg("<br/> -> Richtungsaenderungstest bei " + versatz_index + " Fehler: " + richtungsfehler); if (versatz_index == 1) { richtungsfehler = false; @@ -578,7 +616,7 @@ test = kollisonsabfrage(((uebV_x + 240) + versatz[versatz_index]), (uebV_y + 240) , testV_x, testV_y); if (test[0] != 0) { richtungsfehler = true; - // schreibe_debugger("<br/> -> Kollision mit " + l); + // dbg("<br/> -> Kollision mit " + l); } } } @@ -593,7 +631,7 @@ test = kollisonsabfrage((uebV_x + 240), ((uebV_y + 240) + versatz[versatz_index]), testV_x, testV_y); if (test[0] != 0) { richtungsfehler = true; - // schreibe_debugger("<br/> -> Kollision mit " + l); + // dbg("<br/> -> Kollision mit " + l); } } } @@ -608,7 +646,7 @@ test = kollisonsabfrage(((uebV_x + 240) + versatz[versatz_index]), (uebV_y + 240) , testV_x, testV_y); if (test[0] != 0) { richtungsfehler = true; - // schreibe_debugger("<br/> -> Kollision mit " + l); + // dbg("<br/> -> Kollision mit " + l); } } } @@ -623,7 +661,7 @@ test = kollisonsabfrage((uebV_x + 240), ((uebV_y + 240) + versatz[versatz_index]), testV_x, testV_y); if (test[0] != 0) { richtungsfehler = true; - // schreibe_debugger("<br/> -> Kollision mit " + l); + // dbg("<br/> -> Kollision mit " + l); } } } @@ -636,7 +674,7 @@ if (versatz_index == 2) {uebersicht_icons[i]['y'] = uebersicht_icons[i]['y'] + versatz[versatz_index];} if (versatz_index == 3) {uebersicht_icons[i]['x'] = uebersicht_icons[i]['x'] + versatz[versatz_index];} if (versatz_index == 4) {uebersicht_icons[i]['y'] = uebersicht_icons[i]['y'] + versatz[versatz_index];} - // schreibe_debugger("<br/> -> versetze POI[" + i + "] durch POI[" + j + "] nach " + versatz_index + " um " + versatz[versatz_index] + "<br/>"); + // dbg("<br/> -> versetze POI[" + i + "] durch POI[" + j + "] nach " + versatz_index + " um " + versatz[versatz_index] + "<br/>"); uebV_x = uebersicht_icons[i]['x']; uebV_y = uebersicht_icons[i]['y']; } @@ -644,11 +682,9 @@ } i++; } - - pkt_erzeugen(); } -function pkt_erzeugen() { +function poi_faehnchen_erzeugen() { // Erzeugen der Faehnchen fuer die POI, der array wird durchlaufen und die entsprechenden Informationen in Ebenen dargestellt var i = 1; while (uebersicht_icons[i]) { @@ -660,8 +696,10 @@ var x = parseInt(Math.round(uebersicht_icons[i]['x'] / 30) + 170 - 8); var y = parseInt(Math.round(uebersicht_icons[i]['y'] / 30) + 101 - 8); - - if (y > 360 + 99 - 13) (y = 360 + 99 -13); + // "aha!" + if (y > 360 + 99 - 13) { + y = 360 + 99 - 13; + } // definieren der Styles neueebene.style.position="absolute"; @@ -674,24 +712,24 @@ neueebene.align = "left"; var faehnchentext = msg(uebersicht_icons[i]['name']); - var index = uebersicht_icons[i]['id']; if (uebersicht_icons[i]['icon'] == "sale") { + var index = uebersicht_icons[i]['id']; neueebene.innerHTML = '<a href="#" onClick="qmDetail_anzeigen(' + poi[index]['x'] + ', ' + poi[index]['y'] + ', 0);" class="FaehnchenLink" onMouseOver="faehnchen_einblenden(' + (x + 17) + ', ' + y + ', "' + faehnchentext + '")" onMouseOut="faehnchen_ausblenden();"><img src="/images/' + uebersicht_icons[i]['icon'] + '.gif" border="0"/></a>'; } else if (uebersicht_icons[i]['icon'] == "qm") { - neueebene.innerHTML = '<a href="#" onClick="qmDetail_anzeigen(' + qm[index]['x'] + ', ' + qm[index]['y'] + ',' + index + ');" onMouseOver="faehnchen_einblenden(' + (x + 17) + ', ' + y + ', "' + faehnchentext + '")" onMouseOut="faehnchen_ausblenden();"><img src="/images/qm.gif" border="0"/></a>'; + neueebene.innerHTML = '<a href="#" onClick="qmDetail_anzeigen(' + profil.contracts[0].left + ', ' + profil.contracts[0].top + ', 0);" onMouseOver="faehnchen_einblenden(' + (x + 17) + ', ' + y + ', "' + faehnchentext + '")" onMouseOut="faehnchen_ausblenden();"><img src="/images/qm.gif" border="0"/></a>'; } else { neueebene.innerHTML = '<a href="#" onClick="PoiDetail_anzeigen(' + uebersicht_icons[i]['id'] + ');" class="FaehnchenLink" onMouseOver="faehnchen_einblenden(' + (x + 17) + ', ' + y + ', "' + faehnchentext + '")" onMouseOut="faehnchen_ausblenden();"><img src="/images/' + uebersicht_icons[i]['icon'] + '.gif" border="0" /></a>'; } i++; } - schreibe_debugger("<br/> -> <b>" + (i-1) + " Faehnchen erzeugt</b>"); + dbg("<br/> -> <b>" + (i-1) + " Faehnchen erzeugt</b>"); return true; } function poi_pos_setzen(objekt, i) { // qm setzen - schreibe_debugger("<br> -> Position gestezt"); + dbg("<br> -> Position gestezt"); var x_obj = parseInt(Math.floor(objekt['x'] - x_anf)); var y_obj = parseInt(Math.floor(objekt['y'] - y_anf)); @@ -710,7 +748,7 @@ function qm_pos_setzen(objekt, i) { // qm setzen - schreibe_debugger("<br> -> Position gestezt"); + dbg("<br> -> Position gestezt"); var x_obj = parseInt(Math.floor(objekt['x'] - x_anf)); var y_obj = parseInt(Math.floor(objekt['y'] - y_anf)); @@ -778,6 +816,10 @@ // Ebenen entsprechen ein- oder ausblenden hide_poi_panorama(); hide_poi_luftbild(); + + n_profil = {}; + display_selected_contract(); + show_page("uebersicht"); document.getElementById("qmDetail").style.visibility = "hidden"; document.getElementById("PoiDetail").style.visibility = "hidden"; @@ -785,7 +827,7 @@ document.getElementById("UebersichtPosition").style.visibility = "hidden"; document.getElementById("Ueberschrift").innerHTML = start_ueberschrift; document.getElementById("Untertitel").innerHTML = ""; - schreibe_debugger("<br/> -> <b>Uebersicht anzeigen</b>"); + dbg("<br/> -> <b>Uebersicht anzeigen</b>"); return true; } @@ -896,7 +938,7 @@ x_anf = Math.max(0, Math.round((the_poi['x'] - 180) / 90) * 90); y_anf = Math.min(10440, Math.round((the_poi['y'] - 180) / 90) * 90); - schreibe_debugger("<br/> -> Kacheln laden"); + dbg("<br/> -> Kacheln laden"); // Kacheln von Server holen und dem entsprechenden Bild zuordnen for (var x = 0; x < 4; x++) { for (var y = 0; y < 4; y++) { @@ -964,7 +1006,7 @@ document.getElementById("Uebersicht").style.visibility = "hidden"; document.getElementById("PoiDetail").style.visibility = "visible"; document.getElementById("UebersichtPosition").style.visibility = "visible"; - schreibe_debugger("<br/> -> <b>POI-Detailansicht anzeigen</b>"); + dbg("<br/> -> <b>POI-Detailansicht anzeigen</b>"); return true; } @@ -986,7 +1028,7 @@ document.getElementById("PoiInfoText").innerHTML = poi[aktuelles_objekt]['imagetext'][bild - 1]; document.getElementById("Ueberschrift").innerHTML = poi[aktuelles_objekt]['imageueberschrift'][bild - 1]; document.getElementById("Untertitel").innerHTML = poi[aktuelles_objekt]['imageuntertitel'][bild - 1]; - schreibe_debugger("<br/> -> <b>POI-Foto-Detailansicht anzeigen</b>"); + dbg("<br/> -> <b>POI-Foto-Detailansicht anzeigen</b>"); return true; } @@ -1016,17 +1058,19 @@ for (var x = 0; x < 4; x++) { for (var y = 0; y < 4; y++) { - var img = eval("document.qmimg" + (x + 1) + "" + (y + 1)); - img.src = http_pfad + "/overview/" + (x_anf + (x * 90 )) + "/" + (y_anf + (y * 90 )) + "/" + active_layer_names().join("/"); + + var img = document["qmimg" + (x + 1) + "" + (y + 1)]; + img.src = http_pfad + "/overview/" + (x_anf + (x * 90)) + "/" + (y_anf + (y * 90)) + "/" + active_layer_names().join("/"); - var img = eval("document.qmlupe" + (x + 1) + "" + (y + 1)); - img.src = http_pfad + "/overview/" + (x_anf + (x * 90 )) + "/" + (y_anf + (y * 90 )) + "/" + active_layer_names().join("/"); + var img = document["qmlupe" + (x + 1) + "" + (y + 1)]; + img.src = http_pfad + "/overview/" + (x_anf + (x * 90)) + "/" + (y_anf + (y * 90)) + "/" + active_layer_names().join("/"); } } } -function qmDetail_anzeigen(x_koord, y_koord, objekt) { +function qmDetail_anzeigen(x_koord, y_koord, objekt) +{ // Funktion zum Anzeigen der "meine qm" Karte // Funktion zur Anzeige der POIs im Detail aktuelles_objekt = objekt; @@ -1035,20 +1079,21 @@ // alte Kacheln loeschen for (var x = 0; x < 4; x++) { for (var y = 0; y < 4; y++) { - var img = eval("document.img" + (x + 1) + "" + (y + 1)); + var img = document["img" + (x + 1) + "" + (y + 1)]; img.src = "/infosystem/bilder/spacer.gif"; - var img = eval("document.qmlupe" + (x + 1) + "" + (y + 1)); + var img = document["qmlupe" + (x + 1) + "" + (y + 1)]; img.src = "/infosystem/bilder/spacer.gif"; } } - // Koordinaten auf einen geraden Wert innerhalb des Rasters rechen (es sind nur Vielfache von 90 gueltig), - // Startwert der Kacheln ermitteln + // Koordinaten auf einen geraden Wert innerhalb des Rasters + // umrechnen (es sind nur Vielfache von 90 gueltig), Startwert der + // Kacheln ermitteln x_anf = Math.max(0, Math.round((x_koord - 180) / 90) * 90); y_anf = Math.min(10440, Math.round((y_koord - 180) / 90) * 90); - schreibe_debugger("<br/> -> Kacheln laden (" + x_anf + " / " + y_anf + ")"); + dbg("<br/> -> Kacheln laden (" + x_anf + " / " + y_anf + ")"); // Kacheln von Server holen und dem entsprechenden Bild zuordnen load_sqm_tiles(x_anf, y_anf); @@ -1058,14 +1103,14 @@ var loeschen = eval("document.getElementById('qm" + i + "')"); document.getElementById("qmAusschnitt").removeChild(loeschen); } - schreibe_debugger("<br/> -> " + erzeugte_zeilen + " zeilen geloescht"); + dbg("<br/> -> " + erzeugte_zeilen + " zeilen geloescht"); // qm loeschen for (var i = 1; i <= erzeugte_positionen; i++) { var loeschen = eval("document.getElementById('pos" + i + "')"); document.getElementById("qmDetailKarte").removeChild(loeschen); } - schreibe_debugger("<br/> -> " + erzeugte_positionen + " Positionen geloescht"); + dbg("<br/> -> " + erzeugte_positionen + " Positionen geloescht"); x_obj = parseInt(Math.floor(x_koord - x_anf)); y_obj = parseInt(Math.floor(y_koord - y_anf)); @@ -1087,8 +1132,8 @@ i++; } - schreibe_debugger("<br/> -> " + erzeugte_positionen + " Quadratmeterpositionen"); - schreibe_debugger("<br/> -> " + erzeugte_zeilen + " zeilen fuer Quadratmeter eingezeichnet"); + dbg("<br/> -> " + erzeugte_positionen + " Quadratmeterpositionen"); + dbg("<br/> -> " + erzeugte_zeilen + " zeilen fuer Quadratmeter eingezeichnet"); } // setzen des Positionskaestchens auf der kleinen �bersichtskarte @@ -1111,7 +1156,7 @@ + '<tr> <td width="60" class="PoiNavigation">' + msg('Land') + ':</td><td class="PoiNavigation">' + profil['country'] + '</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">' + profil['anzahl'] + ' m²</td></tr>' - + '<tr> <td width="60" class="PoiNavigation">' + msg('seit') + ':</td><td class="PoiNavigation">' + qm[aktuelles_objekt]['datum'] + '</td></tr>' + + '<tr> <td width="60" class="PoiNavigation">' + msg('seit') + ':</td><td class="PoiNavigation">' + qm[aktuelles_objekt]['date'] + '</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">' + profil['nachricht'] + '</td></tr>' + '</table>'; @@ -1151,7 +1196,11 @@ element.onmousedown = maus_gedrueckt; element.onmouseup = maus_losgelassen; - schreibe_debugger("<br/> -> <b>qm-Detailansicht anzeigen</b>"); + if (profil.contracts) { + display_own_sqm(); + } + + dbg("<br/> -> <b>qm-Detailansicht anzeigen</b>"); return true; } Modified: 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 13:23:45 UTC (rev 1994) +++ branches/xml-class-rework/projects/bos/worldpay-test/contract-image-handler.lisp 2006-10-15 08:58:32 UTC (rev 1995) @@ -12,19 +12,19 @@ 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)))) + (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)) + (color (parse-color (or (second (decoded-handler-path handler req)) "ffff00")))) + (flet ((set-pixel (x y) + (decf x left) + (decf y top) + (setf (aref work-array x y) color))) + (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 :cache-sticky t)))) \ No newline at end of file Modified: branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp 2006-10-14 13:23:45 UTC (rev 1994) +++ branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp 2006-10-15 08:58:32 UTC (rev 1995) @@ -20,8 +20,8 @@ (defmethod handle ((handler reports-xml-handler) req) (with-xml-response req - (destructuring-bind (name *year* &rest arguments) (decoded-handler-path handler req) - (setf *year* (parse-integer *year*)) + (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler req) + (setf *year* (and *year* (parse-integer *year*))) (let ((*contracts-to-process* (sort (remove-if (lambda (contract) (or (not (contract-paidp contract)) (and *year* @@ -37,6 +37,7 @@ (defreport all-contracts () (dolist (contract *contracts-to-process*) (with-element "contract" + (attribute "universal-time" (contract-date contract)) (attribute "date-time" (format-date-time (contract-date contract) :xml-style t)) (attribute "country" (sponsor-country (contract-sponsor contract))) (attribute "sqm-count" (length (contract-m2s contract))))))

1 0

[bknr-cvs] r1994 - branches/xml-class-rework/projects/bos/statistics
by bknr＠bknr.net 14 Oct '06

14 Oct '06

Author: hhubner Date: 2006-10-14 09:23:45 -0400 (Sat, 14 Oct 2006) New Revision: 1994 Added: branches/xml-class-rework/projects/bos/statistics/all-contracts.lxsl Modified: branches/xml-class-rework/projects/bos/statistics/ branches/xml-class-rework/projects/bos/statistics/Makefile branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl Log: Add total sqm sales graphics Property changes on: branches/xml-class-rework/projects/bos/statistics ___________________________________________________________________ Name: svn:ignore - contracts-by-week.xsl contracts-by-week.xml *.svg + all-contracts.xsl contracts-by-week.xsl contracts-by-week.xml *.svg Modified: branches/xml-class-rework/projects/bos/statistics/Makefile =================================================================== --- branches/xml-class-rework/projects/bos/statistics/Makefile 2006-10-14 11:25:47 UTC (rev 1993) +++ branches/xml-class-rework/projects/bos/statistics/Makefile 2006-10-14 13:23:45 UTC (rev 1994) @@ -1,16 +1,19 @@ BASE_URL = http://192.168.254.132:8080/reports-xml -YEAR = 2005 +YEAR = LOGIN = OUTPUT_DIR = ../payment-website/images/statistics -GRAPHICS = contracts-by-week.svg +YEARLY_GRAPHICS = contracts-by-week.svg +TOTAL_GRAPHICS = all-contracts.svg all: - $(MAKE) graphics YEAR=2005 - $(MAKE) graphics YEAR=2006 + $(MAKE) yearly-graphics YEAR=2005 + $(MAKE) yearly-graphics YEAR=2006 + $(MAKE) total-graphics -graphics: $(GRAPHICS) +yearly-graphics: $(YEARLY_GRAPHICS) +total-graphics: $(TOTAL_GRAPHICS) .SUFFIXES: .lxsl .xsl .svg @@ -19,5 +22,5 @@ .xsl.svg: xsltproc -o $*.xml $*.xsl '$(BASE_URL)/$*/$(YEAR)$(LOGIN)' - xsltproc -o $(OUTPUT_DIR)/$*-$(YEAR).svg buildSVGLineChart.xsl $*.xml + xsltproc -o $(OUTPUT_DIR)/$*$(YEAR).svg buildSVGLineChart.xsl $*.xml rm $*.xml \ No newline at end of file Added: branches/xml-class-rework/projects/bos/statistics/all-contracts.lxsl =================================================================== --- branches/xml-class-rework/projects/bos/statistics/all-contracts.lxsl 2006-10-14 11:25:47 UTC (rev 1993) +++ branches/xml-class-rework/projects/bos/statistics/all-contracts.lxsl 2006-10-14 13:23:45 UTC (rev 1994) @@ -0,0 +1,75 @@ +<?xml version="1.0" encoding="UTF-8"?> +<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform" xmlns:loop="http://informatik.hu-berlin.de/loop"> + <xsl:output method="xml"/> + + <xsl:template match="/response"> + <xsl:variable name="total_sqms_sold"> + <xsl:value-of select="sum(contract/@sqm-count)"/> + </xsl:variable> + <graphData> + <sets> + <set title="Contracts" marker-type="none" color="#00ff00"> + <xsl:for-each select="contract"> + <measure> + <xvalue><xsl:value-of select="@universal-time"/></xvalue> + <yvalue><xsl:value-of select="@sqm-count + sum(preceding-sibling::*/@sqm-count)"/></yvalue> + </measure> + </xsl:for-each> + </set> + </sets> + <minx><xsl:value-of select="/response/contract[1]/@universal-time"/></minx> + <maxx><xsl:value-of select="/response/contract[last()]/@universal-time"/></maxx> + <miny>0</miny> + <maxy><xsl:value-of select="$total_sqms_sold"/></maxy> + <title>Total square meters sold</title> + <xvalues> + <xsl:for-each select="/response/contract"> + <xsl:choose> + + <xsl:when test="(substring(preceding-sibling::*[1]/@date-time, 5, 2) != substring(@date-time, 5, 2)) and (substring(@date-time, 5, 2) = '01')"> + <xvalue> + <value><xsl:value-of select="@universal-time"/></value> + <label>Q1/<xsl:value-of select="substring(@date-time, 1, 4)"/></label> + <gridline>true</gridline> + </xvalue> + </xsl:when> + + <xsl:when test="(substring(preceding-sibling::*[1]/@date-time, 5, 2) != substring(@date-time, 5, 2)) and (substring(@date-time, 5, 2) = '04')"> + <xvalue> + <value><xsl:value-of select="@universal-time"/></value> + <label>Q2/<xsl:value-of select="substring(@date-time, 1, 4)"/></label> + <gridline>true</gridline> + </xvalue> + </xsl:when> + + <xsl:when test="(substring(preceding-sibling::*[1]/@date-time, 5, 2) != substring(@date-time, 5, 2)) and (substring(@date-time, 5, 2) = '07')"> + <xvalue> + <value><xsl:value-of select="@universal-time"/></value> + <label>Q3/<xsl:value-of select="substring(@date-time, 1, 4)"/></label> + <gridline>true</gridline> + </xvalue> + </xsl:when> + + <xsl:when test="(substring(preceding-sibling::*[1]/@date-time, 5, 2) != substring(@date-time, 5, 2)) and (substring(@date-time, 5, 2) = '10')"> + <xvalue> + <value><xsl:value-of select="@universal-time"/></value> + <label>Q4/<xsl:value-of select="substring(@date-time, 1, 4)"/></label> + <gridline>true</gridline> + </xvalue> + </xsl:when> + + </xsl:choose> + </xsl:for-each> + </xvalues> + <yvalues> + <loop:for name="i" from="10000" to="$total_sqms_sold" step="10000"> + <yvalue> + <value><xsl:value-of select="$i"/></value> + <label><xsl:value-of select="$i"/></label> + <gridline>true</gridline> + </yvalue> + </loop:for> + </yvalues> + </graphData> + </xsl:template> +</xsl:stylesheet> Modified: branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl =================================================================== --- branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl 2006-10-14 11:25:47 UTC (rev 1993) +++ branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl 2006-10-14 13:23:45 UTC (rev 1994) @@ -38,6 +38,8 @@ <rect width="7" height="22"> </rect> </g> + <g id="none" transform="scale(1)"> + </g> <script type="text/javascript"> <![CDATA[ /* this code was largely reused from the excellent website SVG - Learning by Coding (http://svglbc.datenverdrahten.de/) */

1 0

[bknr-cvs] r1993 - branches/xml-class-rework/projects/bos/m2
by bknr＠bknr.net 14 Oct '06

14 Oct '06

Author: hhubner Date: 2006-10-14 07:25:47 -0400 (Sat, 14 Oct 2006) New Revision: 1993 Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp Log: Additional changes for improved rendering mechanism. Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-14 11:25:17 UTC (rev 1992) +++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-14 11:25:47 UTC (rev 1993) @@ -338,10 +338,11 @@ (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))) + (format t "profil['contracts'] = [ ];~%") (loop for contract in paid-contracts 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 });~%" + (format t "profil.contracts.push({ id: ~A, left: ~A, top: ~A, width: ~A, height: ~A, date: ~S });~%" + (store-object-id contract) left top width height (format-date-time (contract-date contract) :show-time nil)))))))

1 0

[bknr-cvs] r1992 - in branches/xml-class-rework/projects/bos: m2 payment-website/infosystem payment-website/infosystem/de worldpay-test
by bknr＠bknr.net 14 Oct '06

14 Oct '06

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)

1 0

[bknr-cvs] r1991 - in branches/xml-class-rework: bknr/src bknr/src/utils modules
by bknr＠bknr.net 14 Oct '06

14 Oct '06

Author: hhubner Date: 2006-10-14 05:35:08 -0400 (Sat, 14 Oct 2006) New Revision: 1991 Added: branches/xml-class-rework/bknr/src/utils/date-calc.lisp Modified: branches/xml-class-rework/bknr/src/bknr-utils.asd branches/xml-class-rework/modules/bknr-modules.asd Log: Import date calculation routines. Modified: branches/xml-class-rework/bknr/src/bknr-utils.asd =================================================================== --- branches/xml-class-rework/bknr/src/bknr-utils.asd 2006-10-14 09:33:53 UTC (rev 1990) +++ branches/xml-class-rework/bknr/src/bknr-utils.asd 2006-10-14 09:35:08 UTC (rev 1991) @@ -37,5 +37,6 @@ (:file "capability" :depends-on ("utils")) (:file "make-fdf-file" :depends-on ("utils")) (:file "xml" :depends-on ("utils")) + (:file "date-calc") (:file "acl-mp-compat" :depends-on ("package")))))) Added: branches/xml-class-rework/bknr/src/utils/date-calc.lisp =================================================================== --- branches/xml-class-rework/bknr/src/utils/date-calc.lisp 2006-10-14 09:33:53 UTC (rev 1990) +++ branches/xml-class-rework/bknr/src/utils/date-calc.lisp 2006-10-14 09:35:08 UTC (rev 1991) @@ -0,0 +1,719 @@ +;;; Package: date-calc.lisp +;;; Heiko Schroeter, Dec 2005 +;;; +;;; Ver 0.2 ALPHA +;;; License: GNU, Version 2, June 1991 +;;; +;;; Legal issues: +;;; ------------- +;;; This package with all its parts is +;;; Copyright (c) 2005 by Heiko Schroeter. + +;;; This package is free software; you can use, modify and redistribute +;;; under the "GNU General Public License" and the "Artistic License". + +;;; This package is intended as a date-calc module for "everyday" purposes. It is not intended +;;; , nor claims to be, +;;; a bullet proofed implementation of 'scientific' datum calculus. + +;;; Parts taken from DateCalc.el (EMACS, Doug Alcorn, <doug(a)lathi.net>, Ver. 0.1, 2003) +;;; and the +;;; Perl Package "Date::Calc" Version 5.4,Copyright (c) 1995 - 2004 by Steffen Beyer. + +;;; Some Documentation strings are only slightly edited from DateCalc.el + +;;; THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR +;;; IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED +;;; WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + +;;; The following routines are a sidestep for CL Day Of Week (DOW) conformance. +;;; (See Hyperspec 25.1.4.1 X3J13). +;;; "An integer between 0 and 6, inclusive; 0 means Monday, 1 means Tuesday, and so on; 6 means Sunday." +;;; PERLs Date::Calc module range is from 1(Monday) to 7(Sunday). + + +;;; CL conform ,Perl' Conform +;;; ---------- -------------- +;;; cl-day-of-week day-of-week +;;; cl-weeks-in-year weeks-in-year +;;; cl-check-business-p check-business-p +;;; cl-nth-weekday-of-month-year nth-weekday-of-month-year +;;; cl-standard-to-business standard-to-business +;;; cl-business-to-standard business-to-standard +;;; cl-system-clock system-clock +;;; cl-decode-day-of-week decode-day-of-week + +;;; Pls report bugs to schroete @ iup physik uni-bremen de + + +(in-package #:cl-user) + +(defpackage #:date-calc + (:use #:cl) + (:export #:*language* + #:decode-day-of-week + #:cl-decode-day-of-week + #:decode-month + #:decode-language + #:iso-lc + #:iso-uc + #:year-to-days + #:fixed-window + #:center + #:valid-year-p + #:valid-month-p + #:leap-year + #:leap-year-p + #:days-in-month + #:days-in-year + #:check-date + #:check-business-p + #:check-time-p + #:day-of-year + #:date-to-days + #:day-of-week + #:weeks-in-year + #:delta-days + #:week-number + #:week-of-year + #:add-delta-days + #:monday-of-week + #:nth-weekday-of-month-year + #:standard-to-business + #:business-to-standard + #:delta-hms + #:delta-dhms + #:delta-ymd + #:delta-ymdhms + #:normalize-dhms + #:add-delta-dhms + #:add-year-month + #:add-delta-ym + #:add-delta-ymd + #:add-delta-ymdhms + #:system-clock + #:cl-system-clock + #:gmtime + #:localtime + #:today + #:yesterday + #:tomorrow + #:now + #:today-and-now + #:this-year + #:date-to-text + #:date-to-text-long + #:cl-day-of-week + #:cl-weeks-in-year + #:cl-check-business-p + #:cl-nth-weekday-of-month-year + #:cl-standard-to-business + #:cl-business-to-standard)) + +(pushnew :date-calc *features*) +(in-package #:date-calc) + +;;;; Parameters +(defparameter year-of-epoc 70 "Year of reference (epoc)") +(defparameter century-of-epoc 1900 "Century of reference (epoc)") +(defparameter eopoc (+ year-of-epoc century-of-epoc) "reference year (epoc)") + +(defparameter days-in-year-arr (make-array '(2 13) :initial-contents + '((0 31 59 90 120 151 181 212 243 273 304 334 365) + (0 31 60 91 121 152 182 213 244 274 305 335 366)))) + +(defparameter days-in-month-arr (make-array '(2 13) :initial-contents + '((0 31 28 31 30 31 30 31 31 30 31 30 31) + (0 31 29 31 30 31 30 31 31 30 31 30 31)))) + +(defparameter languages 11) +(defparameter *language* 1) ; Default English + +;; (defconstant num-of-lingos (1+ languages)) + +(defparameter month-to-text (make-hash-table)) +(setf (gethash 0 month-to-text) + #("???" "???" "???" "???" + "???" "???" "???" "???" + "???" "???" "???" "???" "???")) +(setf (gethash 1 month-to-text) + #("???" "January" "February" "March" + "April" "May" "June" "July" "August" + "September" "October" "November" "December")) +(setf (gethash 2 month-to-text) + #("???" "janvier" "fevrier" "mars" + "avril" "mai" "juin" "juillet" "aout" + "septembre" "octobre" "novembre" "decembre")) +(setf (gethash 3 month-to-text) + #("???" "Januar" "Februar" "Maerz" + "April" "Mai" "Juni" "Juli" "August" + "September" "Oktober" "November" "Dezember")) +(setf (gethash 4 month-to-text) + #("???" "enero" "febrero" "marzo" + "abril" "mayo" "junio" "julio" "agosto" + "septiembre" "octubre" "noviembre" "diciembre")) +(setf (gethash 5 month-to-text) + #("???" "janeiro" "fevereiro" "marco" + "abril" "maio" "junho" "julho" "agosto" + "setembro" "outubro" "novembro" "dezembro")) +(setf (gethash 6 month-to-text) + #("???" "januari" "februari" "maart" + "april" "mei" "juni" "juli" "augustus" + "september" "october" "november" "december")) +(setf (gethash 7 month-to-text) + #("???" "Gennaio" "Febbraio" "Marzo" + "Aprile" "Maggio" "Giugno" "Luglio" "Agosto" + "Settembre" "Ottobre" "Novembre" "Dicembre")) +(setf (gethash 8 month-to-text) + #("???" "januar" "februar" "mars" + "april" "mai" "juni" "juli" "august" + "september" "oktober" "november" "desember")) +(setf (gethash 9 month-to-text) + #("???" "januari" "februari" "mars" + "april" "maj" "juni" "juli" "augusti" + "september" "oktober" "november" "december")) +(setf (gethash 10 month-to-text) + #("???" "januar" "februar" "marts" + "april" "maj" "juni" "juli" "august" + "september" "oktober" "november" "december")) +(setf (gethash 11 month-to-text) + #("???" "tammikuu" "helmikuu" "maaliskuu" + "huhtikuu" "toukokuu" "kesaekuu" "heinaekuu" + "elokuu" "syyskuu" "lokakuu" "marraskuu" "joulukuu")) + +(defparameter day-of-week-to-text (make-hash-table)) +(setf (gethash 0 day-of-week-to-text) + #("???" "???" "???" "???" "???" "???" "???" "???")) +(setf (gethash 1 day-of-week-to-text) + #("???" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) +(setf (gethash 2 day-of-week-to-text) + #("???" "Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche")) +(setf (gethash 3 day-of-week-to-text) + #("???" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag" "Sonntag")) +(setf (gethash 4 day-of-week-to-text) + #("???" "Lunes" "Martes" "Miercoles" "Jueves" "Viernes" "Sabado" "Domingo")) +(setf (gethash 5 day-of-week-to-text) + #("???" "Segunda-feira" "Terca-feira" "Quarta-feira" "Quinta-feira" "Sexta-feira" "Sabado" "Domingo")) +(setf (gethash 6 day-of-week-to-text) + #("???" "Maandag" "Dinsdag" "Woensdag" "Donderdag" "Vrijdag" "Zaterdag" "Zondag")) +(setf (gethash 7 day-of-week-to-text) + #("???" "Lunedi" "Martedi" "Mercoledi" "Giovedi" "Venerdi" "Sabato" "Domenica")) +(setf (gethash 8 day-of-week-to-text) + #("???" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "loerdag" "soendag")) +(setf (gethash 9 day-of-week-to-text) + #("???" "mandag" "tisdag" "onsdag" "torsdag" "fredag" "loerdag" "soendag")) +(setf (gethash 10 day-of-week-to-text) + #("???" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "loerdag" "soendag")) +(setf (gethash 11 day-of-week-to-text) + #("???" "maanantai" "tiistai" "keskiviikko" "torstai" "perjantai" "lauantai" "sunnuntai")) + +(defparameter day-of-week-abbreviation (make-hash-table)) +(setf (gethash 0 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) +(setf (gethash 1 day-of-week-abbreviation) #("??" "Mon" "Tue" "Wen" "Thu" "Fri" "Sat" "Sun")) +(setf (gethash 2 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) +(setf (gethash 3 day-of-week-abbreviation) #("??" "Mo" "Di" "Mi" "Do" "Fr" "Sa" "So")) +(setf (gethash 4 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) +(setf (gethash 5 day-of-week-abbreviation) #("???" "2" "3" "4" "5" "6" "Sam" "Dom")) +(setf (gethash 6 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) +(setf (gethash 7 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) +(setf (gethash 8 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) +(setf (gethash 9 day-of-week-abbreviation) #("??" "Mo" "Ti" "On" "To" "Fr" "Lo" "So")) +(setf (gethash 10 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) +(setf (gethash 11 day-of-week-abbreviation) #("" "" "" "" "" "" "" "")) + +(defparameter long-format (make-array '(12) :initial-contents + '(("~A, ~A ~A ~A" 10) ; 0 Default, the second value describes order: + ("~A, ~A ~A ~A" 10) ; 1 English 11=DMY 10=MDY see #'date-to-text-long + ("~A ~A ~A ~A" 10) ; 2 Francais + ("~A, den ~A ~A ~A" 11) ; 3 Deutsch + ("~A, ~A de ~A de ~A" 10) ; 4 Espanol + ("~A, dia ~A de ~A de ~A" 10) ; 5 Portugues + ("~A, ~A ~A ~A" 10) ; 6 Nederlands + ("~A, ~A ~A ~A" 10) ; 7 Italiano + ("~A, ~A. ~A ~A" 10) ; 8 Norsk + ("~A, ~A ~A ~A" 10) ; 9 Svenska + ("~A, ~A. ~A ~A" 10) ; 10 Dansk + ("~A, ~A. ~A ta ~A" 10)))) ; 11 suomi + +(defparameter language-to-text + (vector "???" "English" "Francais" "Deutsch" "Espanol" + "Portugues" "Nederlands" "Italiano" "Norsk" + "Svenska" "Dansk" "suomi")) + +;;;; Functions +(defun decode-day-of-week (str) + "Returns number of weekday. STR can partially name the Weekday. DOW is not CL conform." + (let ((week-vector (gethash *language* day-of-week-to-text)) + (i 0)) + (loop for weekday across week-vector + until (search str weekday :test #'char-equal) + do (incf i) + finally (return (if (<= i 7) i nil))))) + +(defun cl-decode-day-of-week (str) + "Returns number of weekday. STR can partially name the Weekday. DOW is CL conform." + (let ((week-vector (gethash *language* day-of-week-to-text)) + (i 0)) + (loop for weekday across week-vector + until (search str weekday :test #'char-equal) + do (incf i) + finally (return (if (<= i 7) (1- i) nil))))) + +(defun decode-month (str) + "Returns number of month. STR can partially name the month. Computes a (search ...:test #'char-equal)." + (let ((month-vector (gethash *language* month-to-text)) + (i 0)) + (loop for month across month-vector + until (search str month :test #'char-equal) + do (incf i) + finally (return (if (<= i 12) i nil))))) + +(defun decode-language (num) + "Returns the Language of number NUM." + (svref language-to-text num)) + +(defun iso-lc (char) + "Returns lower case CHAR." + (char-downcase char)) + +(defun iso-uc (char) + "Returns upper case CHAR." + (char-upcase char)) + +(defun year-to-days (year) + "Returns the number of days for YEAR since 1 Jan 1." + (+ (- (+ (* year 365) (ash year -2)) + (floor (/ (ash year -2) 25))) + (ash (floor (/ (ash year -2) 25)) -2))) + +(defun fixed-window (year) + "Convert two digit YEAR to four digit YEAR; YEAR<=70 -> 2000+YEAR; YEAR<100&&>70 -> 1900+YEAR." + (if (and (> year 70) (< year 100)) + (+ 1900 year) + (+ 2000 year))) + +(defun center (string width) + "Return a string that is WIDTH long with STRING centered in it." + (let* ((pad (- width (length string))) + (lpad (truncate pad 2)) + (rpad (- pad (truncate pad 2)))) + (if (<= pad 0) + string + (concatenate 'string (make-string lpad :initial-element #\Space) string (make-string rpad :initial-element #\Space))))) + +(defun normalize-time (dd dh dm ds) +"Internal fn for normalize-dhms. Returns the normalized (values DD DH DM DS)." + (values (+ dd (floor (+ dh (floor (+ dm (floor ds 60)) 60)) 24)) ; dd + (- (+ dh (floor (+ dm (floor ds 60)) 60)) + (* (floor (+ dh (floor (+ dm (floor ds 60)) 60)) 24) 24)) ; dh + (- (+ dm (floor ds 60)) (* (floor (+ dm (floor ds 60)) 60) 60)) ;dm + (- ds (* (floor ds 60) 60)))) ;ds + +(defun normalize-ranges (dd dh dm ds) +"Internal fn for normalize-dhms. Returns the normalized (values DD DH DM DS). This function prevents overflow errors on systems with short longs (e.g. 32-bits) (If need be for CL ???)." + (normalize-time (+ dd (floor dh 24)) + (+ (- dh (* (floor dh 24) 24)) (floor dm 60)) + (- dm (* (floor dm 60) 60)) + ds)) + +(defun normalize-signs (dd dh dm ds) +"Internal fn for normalize-dhms." + (let* ((quot (floor ds 86400)) + (ds1 (- ds (* quot 86400))) + (dd1 (+ dd quot))) + (setq dh 0 dm 0) + (if (not (= dd1 0)) + (if (> dd1 0) + (when (< ds 0) + (setq ds1 (+ ds 86400) + dd1 (1- dd1))) + (when (> ds 0) + (setq ds1 (- ds 86400) + dd1 (1+ dd1))))) + (if (not (= ds1 0)) + (normalize-time dd1 dh dm ds1) + (values dd1 dh dm ds1)))) + +(defun valid-year-p (year) (>= year 1)) +(defun valid-month-p (month) (and month (>= month 1) (<= month 12))) + +(defun leap-year (year) + "This function returns 1 if the given YEAR is a leap year and 0 otherwise." + (if (or (and (zerop (mod year 4)) + (not (zerop (mod year 100)))) + (zerop (mod year 400))) + 1 + 0)) + +(defun leap-year-p (year) + "This function returns t if the given YEAR is a leap year and nil otherwise." + (if (or (and (zerop (mod year 4)) + (not (zerop (mod year 100)))) + (zerop (mod year 400))) + t + nil)) + +(defun days-in-month (year month) + "This function returns the number of days in the given MONTH of the given YEAR." + (if (and (valid-year-p year) + (valid-month-p month)) + (aref days-in-month-arr (leap-year year) month))) + +(defun days-in-year (year &optional month) + "This function returns the number of days in the given YEAR and optional MONTH. If MONTH is [1..12], return the number of days in that YEAR as of the last of that MONTH." + (aref days-in-year-arr (leap-year year) (if (and month (>= month 0) (<= month 12)) + month + 12))) + +(defun check-date (year month day) + "This function returns t if the given three numerical values YEAR MONTH DAY constitute a valid date, and nil otherwise." + (and (valid-year-p year) + (valid-month-p month) + (>= day 1) + (<= day (days-in-month year month)))) + +(defun check-time-p (hour min sec) + "This function returns t if the given three numerical values HOUR MIN SEC constitute a valid time, and nil otherwise." + (and (>= hour 0) (< hour 24) + (>= min 0) (< min 60) + (>= sec 0) (< sec 60))) + +(defun day-of-year (year month day) + "This function returns the sum of the number of days in the months starting with January up to and including MONTH in + the given year YEAR. 0 on failure." + (if (check-date year month day) + (+ day (aref days-in-year-arr (leap-year year) (1- month))) + 0)) + +(defun date-to-days (year month day) + "This function returns the (absolute) number of the day of the given date, where counting starts at the 1.Jan 1." + (if (check-date year month day) + (+ (year-to-days (1- year)) + (day-of-year year month day)) + 0)) + +(defun day-of-week (year month day) + "This function returns the DOW of YEAR MONTH DAY. DOW not CL conform." + (let ((days (date-to-days year month day))) + (if (> days 0) + (1+ (mod (1- days) 7)) + days))) + +(defun cl-day-of-week (year month day) + "This function returns the DOW of YEAR MONTH DAY. DOW CL conform." + (let ((days (date-to-days year month day))) + (if (> days 0) + (mod (1- days) 7) + days))) + +(defun weeks-in-year (year) + "This function returns the number of weeks in the given YEAR, i.e., either 52 or 53." + (if (or (= 4 (day-of-week year 1 1)) + (= 4 (day-of-week year 12 31))) + 53 52)) + +(defun cl-weeks-in-year (year) + "This function returns the number of weeks in the given YEAR for CL DOW conform numbering (Monday=0)., i.e., either 52 or 53." + (if (or (= 3 (cl-day-of-week year 1 1)) + (= 3 (cl-day-of-week year 12 31))) + 53 52)) + +(defun check-business-p (year week dow) + "This function returns true if the given three numerical values YEAR WEEK DOW constitute a valid date in business format, and nil otherwise. Beware that this function does NOT compute whether a given date is a business day (i.e., Monday to Friday)! To do so, use (< (day-of-week year month day) 6) instead. DOW not CL conform." + (and (>= year 1) + (>= week 1) + (<= week (weeks-in-year year)) + (>= dow 1) + (<= dow 7))) + +(defun cl-check-business-p (year week dow) + "This function returns true if the given three numerical values YEAR WEEK DOW constitute a valid date in business format for CL (Monday=0), and nil otherwise. DOW is CL conform." + (and (>= year 1) + (>= week 1) + (<= week (weeks-in-year year)) + (>= dow 0) + (<= dow 6))) + +(defun delta-days (year1 month1 day1 year2 month2 day2) + "This function returns the difference in days between Y1 M1 D1 and Y2 M2 D2." + (- (date-to-days year2 month2 day2) + (date-to-days year1 month1 day1))) + +(defun week-number (year month day) + "This function returns the number of the week of the given Y M D lies in. If the given date lies in the LAST week of the PREVIOUS year, 0 is returned." + (let ((first-jan (1- (day-of-week year 1 1)))) + (if (< first-jan 4) + (1+ (truncate (+ first-jan (delta-days year 1 1 year month day)) 7)) + (+ 0 (truncate (+ first-jan (delta-days year 1 1 year month day)) 7))))) ; + 0..-> only return one value + +(defun week-of-year (year month day) + "Return (values week year) where week is the week number of YEAR" + (if (not (check-date year month day)) + nil + (progn + (let ((week (week-number year month day))) + (if (= week 0) + (values (weeks-in-year (1- year)) year) + (progn + (if (> week (weeks-in-year year)) + (values 1 (1+ year)) + (values week year)))))))) + +(defun add-delta-days (year month day delta) + "This function returns (values year month day) such that it is YEAR MONTH DAY plus DELTA days" +;; Be careful when changing things in this fn ! Side effects ! +;; Fairly direct port from the PERL routine. Pretty imperative style. + (let* ((days (+ (date-to-days year month day) delta)) + (y1 (round (/ days 365.2425))) + (d1 (- days (year-to-days y1)))) + (when (> days 0) + (progn + (if (< d1 1) + (setf d1 (- days (year-to-days (1- y1)))) ; then + (setf y1 (1+ y1))) ; else + (if (> d1 (days-in-year y1)) + (setf d1 (- d1 (days-in-year y1)) + y1 (1+ y1))) + (loop for index downfrom 12 to 1 + until (> d1 (days-in-year y1 index)) + finally (return (values y1 (1+ index) (- d1 (days-in-year y1 index))))))))) ; index=month just one to low here after until, thats why (1+ index) as return value + +(defun monday-of-week (week year) + "Return (values year month day) where month and day correspond to the Monday of WEEK in YEAR" + (let ((erst (1- (day-of-week year 1 1)))) + (if (< erst 4) + (add-delta-days year 1 1 (- (* (1- week) 7) erst)) + (add-delta-days year 1 1 (- (* week 7) erst))))) + +(defun nth-weekday-of-month-year (year month dow n) + "This function returns the (year month day) of the N-th day of week DOW in the given MONTH and YEAR; such as, for example, the 3rd Thursday of a given month and year. DOW is not CL conform." + (when (and (check-date year month 1) ; check params + (>= dow 1) (<= dow 7) + (> n 0) (< n 5)) + (let* ((erst (day-of-week year month 1)) + (tow (if (< dow erst) + (+ dow 7) + dow))) + (multiple-value-bind (y m d) + (add-delta-days year month 1 (+ (- tow erst) (* (1- n) 7))) + (when (= month m) + (values y m d)))))) + +(defun cl-nth-weekday-of-month-year (year month dow n) + "This function returns the (year month day) of the N-th day of week DOW in the given MONTH and YEAR; such as, for example, the 3rd Thursday of a given month and year. DOW is CL conform." + (when (and (check-date year month 1) ; check params + (>= dow 0) (<= dow 6) + (> n 0) (< n 5)) + (let* ((erst (cl-day-of-week year month 1)) + (tow (if (< dow erst) + (+ dow 7) + dow))) + (multiple-value-bind (y m d) + (add-delta-days year month 1 (+ (- tow erst) (* (1- n) 7))) + (when (= month m) + (values y m d)))))) + +(defun standard-to-business (year month day) + "This function converts a given date from standard notation YEAR MONTH DAY to business notation year week dow. DOW is not CL conform." + (multiple-value-bind (week y) (week-of-year year month day) + (when week + (values y week (day-of-week year month day))))) + +(defun cl-standard-to-business (year month day) + "This function converts a given date from standard notation YEAR MONTH DAY to business notation year week day of week. DOW is CL conform." + (multiple-value-bind (week y) (week-of-year year month day) + (when week + (values y week (cl-day-of-week year month day))))) + + +(defun business-to-standard (year week dow) + "This function converts a given date from business notation YEAR WEEK DOW to standard notation year month day. DOW is not CL conform." + (when (check-business-p year week dow) + (let* ((erst (day-of-week year 1 1)) + (delta (+ (- dow erst) (* 7 (1- (+ week (if (> erst 4) 1 0))))))) + (add-delta-days year 1 1 delta)))) + +(defun cl-business-to-standard (year week dow) + "This function converts a given date from business notation YEAR WEEK DOW to standard notation year month day. DOW is CL conform." + (when (cl-check-business-p year week dow) + (let* ((erst (cl-day-of-week year 1 1)) + (delta (+ (- dow erst) (* 7 (1- (+ week (if (> erst 4) 1 0))))))) + (add-delta-days year 1 1 delta)))) + +(defun delta-hms (hour1 min1 sec1 hour2 min2 sec2) + "This function returns the difference of H1 M1 S1 and H2 M2 S2 in (values d h m s)." + (when (and (check-time-p hour1 min1 sec1) + (check-time-p hour2 min2 sec2)) + (normalize-signs 0 0 0 (- (+ sec2 (* 60 (+ min2 (* 60 hour2)))) + (+ sec1 (* 60 (+ min1 (* 60 hour1)))))))) + +(defun delta-dhms (year1 month1 day1 hour1 min1 sec1 year2 month2 day2 hour2 min2 sec2) + "Returns the difference in (values d h m s) between the two given dates with times (Y1 M1 D1 H1 MIN1 SEC1 and Y2 M2 D2 H2 MIN2 SEC2)." + (let ((dd (delta-days year1 month1 day1 year2 month2 day2))) + (multiple-value-bind (d h m s) (delta-hms hour1 min1 sec1 hour2 min2 sec2) + (if d + (values (+ d dd) h m s) + (values d h m s))))) + +(defun delta-ymd (year1 month1 day1 year2 month2 day2) + "This function returns the difference (values YEAR MONTH DAYS) between the two dates Y1M1D1 and Y2M2D2." + (if (and (check-date year1 month1 day1) + (check-date year2 month2 day2)) + (values (- year2 year1)(- month2 month1)(- day2 day1)) + nil)) + +(defun delta-ymdhms (year1 month1 day1 hour1 min1 sec1 + year2 month2 day2 hour2 min2 sec2) + "This function returns the difference (values YEAR MONTH DAYS HOUR MINUTE SEC) between +the two dates Y1 M1 D1 H1 MI1 S1 and Y2 M2 D2 H2 MI2 S2." + (multiple-value-bind (y m d) (delta-ymd year1 month1 day1 year2 month2 day2) + (when y + (multiple-value-bind (dd hh mm ss) + (delta-hms hour1 min1 sec1 hour2 min2 sec2) + (when dd + (values y m (+ dd d) hh mm ss)))))) + +(defun normalize-dhms (day hour min sec) + "This function takes four arbitrary values for days, hours, minutes and seconds (which may have different signs) and renormalizes them so that the values for hours, minutes and seconds will lie in the ranges [-23..23], [-59..59] and [-59..59], respectively, and so that they have the same sign." + (multiple-value-bind (dd dh dm ds) (normalize-ranges day hour min sec) + (when ds + (normalize-signs dd dm dh (+ ds (* 60 (+ dm (* 60 dh)))))))) + +(defun add-delta-dhms (year month day hour min sec dd dh dm ds) + "This function serves to add a days, hours, minutes and seconds offset to a given date and time (YEAR MONTH DAY HOUR MINUTE SECOND DDAY DHOUR DMINUTE DSECOND), in order to answer questions like \"today and now plus 7 days but minus 5 hours and then plus 30 minutes, what date and time gives that?\". Returns: (values y m d h min sec)" + (when (and (check-date year month day) + (check-time-p hour min sec)) + (multiple-value-bind (d1 h1 m1 s1) (normalize-ranges dd dh dm ds) + (when d1 + (progn + (let ((s2 (+ s1 (* 60 (+ m1 (* 60 h1))) (+ sec (* 60 (+ min (* 60 hour))))))) + (when (= 0 s2) + (multiple-value-bind (yy mm ddd) (add-delta-days year month day d1) + (values yy mm ddd 0 0 0))) + (when (< s2 0) + (multiple-value-bind (dd1 ss2) (truncate s2 86400) + (multiple-value-bind (ddd hh mm ss) (normalize-time (+ d1 dd1) 0 0 ss2) + (multiple-value-bind (yy mmm dddd) (add-delta-days year month day ddd) + (values yy mmm dddd hh mm ss))))) + (when (> s2 0) + (multiple-value-bind (ddd hh mm ss) (normalize-time d1 0 0 s2) + (multiple-value-bind (yy mmm dddd) (add-delta-days year month day ddd) + (values yy mmm dddd hh mm ss)))))))))) + +(defun add-year-month (year month dy dm) + "This function adds DYEAR and DMONTH offset to YEAR and MONTH." + (let ((mt (+ month dm))) + (if (> mt 0) + (multiple-value-bind (jahre monate) (truncate (1- mt) 12) + (values (+ jahre (+ year dy)) (1+ monate))) + (multiple-value-bind (jahre monate) (truncate mt 12) + (values (+ (+ year dy) jahre -1) (+ 12 monate)))))) + +(defun add-delta-ym (year month day dy dm) + "This function adds DYEAR and DMONTH offset to YEAR MONTH DAY." + (when (check-date year month day) + (multiple-value-bind (jahr monat) (add-year-month year month dy dm) + (values jahr monat day)))) + +(defun add-delta-ymd (year month day dy dm dd) + "This function adds DYEAR DMONTH and DDAY offset to YEAR MONTH DAY." + (when (check-date year month day) + (multiple-value-bind (jahr monat tag) (add-delta-ym year month day dy dm) + (when jahr + (add-delta-days jahr monat tag dd))))) + +(defun add-delta-ymdhms (year month day hour min sec dyear dmonth dday dh dm ds) + "This function is the same as add-delta-ymd except that a time offset may be given in addition to the year, month and day offset" + (multiple-value-bind (jahr monat) (add-year-month year month dyear dmonth) + (when jahr + (add-delta-dhms jahr monat 1 hour min sec (+ dday (1- day)) dh dm ds)))) + +(defun system-clock (gmt time) + "This function returns (values year month day hour min sec doy dow dst) based on current system clock. DOW is not CL conform." + (multiple-value-bind (second minute hour day month year dow daylight-p dst) + (decode-universal-time time) + (declare (ignorable daylight-p)) + (let ((doy (day-of-year year month day))) + (if gmt + (multiple-value-bind (jahr monat tag std min sek) + (add-delta-dhms year month day hour minute second 0 0 dst 0) + (values jahr monat tag std min sek doy (1+ dow) dst)) + (values year month day hour minute second doy (1+ dow) dst))))) + +(defun cl-system-clock (gmt time) + "This function returns (values year month day hour min sec doy dow dst) based on current system clock. DOW is CL conform." + (multiple-value-bind (second minute hour day month year dow daylight-p dst) + (decode-universal-time time) + (declare (ignorable daylight-p)) + (let ((doy (day-of-year year month day))) + (if gmt + (multiple-value-bind (jahr monat tag std min sek) + (add-delta-dhms year month day hour minute second 0 0 dst 0) + (values jahr monat tag std min sek doy dow dst)) + (values year month day hour minute second doy dow dst))))) + +;;;;;;; Add gmt flag +(defun gmtime () + (system-clock t (get-universal-time))) + +(defun localtime () + (system-clock nil (get-universal-time))) + +(defun today () + "This function returns (year month day) for today." + (multiple-value-bind (sec minute hour day month year) (get-decoded-time) + (declare (ignorable sec minute hour)) + (values year month day))) + +(defun yesterday () + (multiple-value-bind (jahr monat tag) (today) + (add-delta-days jahr monat tag -1))) + +(defun tomorrow () + (multiple-value-bind (jahr monat tag) (today) + (add-delta-days jahr monat tag 1))) + +(defun now () + "This function returns (hour minute second) for right now." + (multiple-value-bind (second minute hour) (get-decoded-time) + (values hour minute second))) + +(defun today-and-now () + "This function returns (year month day hour minute second) for the current date and time." + (multiple-value-bind (second minute hour day month year) (get-decoded-time) + (values year month day hour minute second))) + +(defun this-year () + "This function returns the current year in localtime." + (multiple-value-bind (second minute hour day month year) (get-decoded-time) + (declare (ignorable second minute hour day month)) + year)) + +(defun date-to-text (year month day) + "Return a pretty print string of YEAR MONTH DAY in DOW-TXT(SHORT) DAY MONTH YEAR with a little bit of sorting for language." + (let ((prn (first (aref long-format *language*)))) ; get print format + (multiple-value-bind (a b c) ; What order is the date DMY , MDY .... + (let ((k (second (aref long-format *language*)))) + (case k ; return the order of DMY + (10 (values month day year)) + (11 (values day month year)) + (otherwise (values month day year)))) ; return english by default + (format nil prn ; make the return string + (svref (gethash *language* day-of-week-abbreviation) ; Get Name of Weekday + (day-of-week year month day)) + a b c)))) + +(defun date-to-text-long (year month day) + "Return a pretty print string of YEAR MONTH DAY in DOW-TXT(LONG) DAY MONTH YEAR with a little bit of sorting for language." + (let ((prn (first (aref long-format *language*)))) ; get print format + (multiple-value-bind (a b c) ; What order is the date DMY , MDY .... + (let ((k (second (aref long-format *language*)))) + (case k ; return the order of DMY + (10 (values month day year)) + (11 (values day month year)) + (otherwise (values month day year)))) ; return english by default + (format nil prn ; make the return string + (svref (gethash *language* day-of-week-to-text) ; Get Name of Weekday + (day-of-week year month day)) + a b c)))) + Modified: branches/xml-class-rework/modules/bknr-modules.asd =================================================================== --- branches/xml-class-rework/modules/bknr-modules.asd 2006-10-14 09:33:53 UTC (rev 1990) +++ branches/xml-class-rework/modules/bknr-modules.asd 2006-10-14 09:35:08 UTC (rev 1991) @@ -25,7 +25,7 @@ :bknr-utils :puri :stem - :mime + #+(or) :mime :bknr :klammerscript #+(not allegro)

1 0

[bknr-cvs] r1990 - branches/xml-class-rework/projects/bos/statistics
by bknr＠bknr.net 14 Oct '06

14 Oct '06

Author: hhubner Date: 2006-10-14 05:33:53 -0400 (Sat, 14 Oct 2006) New Revision: 1990 Modified: branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl Log: Increase Y-Label font size Modified: branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl =================================================================== --- branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl 2006-10-14 07:51:44 UTC (rev 1989) +++ branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl 2006-10-14 09:33:53 UTC (rev 1990) @@ -446,7 +446,7 @@ <xsl:value-of select="1000-1000* (($yvalue - ($min)) div ($max - $min))"/> )</xsl:attribute> - <text x="-10" > + <text x="-10" font-size="20pt"> <xsl:attribute name="style">text-anchor: <xsl:choose> <xsl:when test="$axis=1">end</xsl:when>

1 0

[bknr-cvs] r1989 - in branches/xml-class-rework/projects/bos: m2 payment-website/images payment-website/images/statistics statistics worldpay-test
by bknr＠bknr.net 14 Oct '06

14 Oct '06

Author: hhubner Date: 2006-10-14 03:51:44 -0400 (Sat, 14 Oct 2006) New Revision: 1989 Added: branches/xml-class-rework/projects/bos/payment-website/images/statistics/ branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp Removed: branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp branches/xml-class-rework/projects/bos/statistics/ branches/xml-class-rework/projects/bos/statistics/Makefile branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp Log: XML statistics generation and batch SVG rendering. Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-14 07:51:44 UTC (rev 1989) @@ -387,3 +387,6 @@ (make-contract sponsor (random-elt (cons (1+ (random 300)) '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10 10 10 10 10 10 30 30 30))) :paidp t)))) + + + \ No newline at end of file Property changes on: branches/xml-class-rework/projects/bos/payment-website/images/statistics ___________________________________________________________________ Name: svn:ignore + * Property changes on: branches/xml-class-rework/projects/bos/statistics ___________________________________________________________________ Name: svn:ignore - contracts-by-week.xml *.svg + contracts-by-week.xsl contracts-by-week.xml *.svg Modified: branches/xml-class-rework/projects/bos/statistics/Makefile =================================================================== --- branches/xml-class-rework/projects/bos/statistics/Makefile 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/statistics/Makefile 2006-10-14 07:51:44 UTC (rev 1989) @@ -1,7 +1,8 @@ BASE_URL = http://192.168.254.132:8080/reports-xml YEAR = 2005 -LOGIN = +LOGIN = +OUTPUT_DIR = ../payment-website/images/statistics GRAPHICS = contracts-by-week.svg @@ -18,5 +19,5 @@ .xsl.svg: xsltproc -o $*.xml $*.xsl '$(BASE_URL)/$*/$(YEAR)$(LOGIN)' - xsltproc -o $*-$(YEAR).svg buildSVGLineChart.xsl $*.xml + xsltproc -o $(OUTPUT_DIR)/$*-$(YEAR).svg buildSVGLineChart.xsl $*.xml rm $*.xml \ No newline at end of file Modified: branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl =================================================================== --- branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl 2006-10-14 07:51:44 UTC (rev 1989) @@ -21,7 +21,7 @@ <xsl:variable name="minx"> <xsl:value-of select="minx"/> </xsl:variable> - <svg width="1200" height="1200" onload="getSVGDoc(evt)" onzoom="ZoomControl()"> + <svg width="800" height="600" onload="getSVGDoc(evt)" onzoom="ZoomControl()"> <defs> <g id="star" transform="scale(0.21)"> <polyline points="48,16,16,96,96,48,0,48,80,96"> Modified: branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl =================================================================== --- branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl 2006-10-14 07:51:44 UTC (rev 1989) @@ -17,17 +17,26 @@ <set title="Contracts" marker-type="triangle" color="green"> <xsl:for-each select="week"> <measure> - <xvalue><xsl:value-of select="substring(@key, 6)"/></xvalue> + <xvalue><xsl:value-of select="@week-first-yday"/></xvalue> <yvalue><xsl:value-of select="@contracts"/></yvalue> </measure> </xsl:for-each> </set> </sets> <minx>1</minx> - <maxx>52</maxx> + <maxx>365</maxx> <miny>0</miny> <maxy><xsl:value-of select="$max_contracts"/></maxy> <title>Contracts by week for year <xsl:value-of select="$year"/></title> + <xvalues> + <xsl:for-each select="month"> + <xvalue> + <value><xsl:value-of select="@start-yday"/></value> + <label><xsl:value-of select="@name"/></label> + <gridline>true</gridline> + </xvalue> + </xsl:for-each> + </xvalues> <yvalues> <loop:for name="i" from="20" to="$max_contracts" step="20"> <yvalue> Deleted: branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl =================================================================== --- branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl 2006-10-14 07:51:44 UTC (rev 1989) @@ -1,49 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> - -<xsl:stylesheet xmlns:loop="http://informatik.hu-berlin.de/loop" xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0"> - <xsl:output method="xml"/> - - <xsl:template match="/response"> - <xsl:variable name="year"> - <xsl:value-of select="substring(/response/week[1]/@key, 1, 4)"/> - </xsl:variable> - <xsl:variable name="max_contracts"> - <xsl:for-each select="week"> - <xsl:sort select="@contracts" data-type="number" order="descending"/> - <xsl:if test="position()=1"><xsl:value-of select="@contracts"/></xsl:if> - </xsl:for-each> - </xsl:variable> - <graphData> - <sets> - <set title="Contracts" marker-type="triangle" color="green"> - <xsl:for-each select="week"> - <measure> - <xvalue><xsl:value-of select="substring(@key, 6)"/></xvalue> - <yvalue><xsl:value-of select="@contracts"/></yvalue> - </measure> - </xsl:for-each> - </set> - </sets> - <minx>1</minx> - <maxx>52</maxx> - <miny>0</miny> - <maxy><xsl:value-of select="$max_contracts"/></maxy> - <title>Contracts by week for year <xsl:value-of select="$year"/></title> - <yvalues> - <xsl:call-template name="for-loop-id4477040"><xsl:with-param name="i" select="20"/><xsl:with-param name="toid4477040" select="$max_contracts"/><xsl:with-param name="stepid4477040" select="20"/><xsl:with-param name="year" select="$year"/><xsl:with-param name="max_contracts" select="$max_contracts"/></xsl:call-template> - </yvalues> - </graphData> - </xsl:template> -<xsl:template name="for-loop-id4477040"><xsl:param name="i"/><xsl:param name="toid4477040"/><xsl:param name="stepid4477040"/><xsl:param name="year"/><xsl:param name="max_contracts"/> - <yvalue> - <value><xsl:value-of select="$i"/></value> - <label><xsl:value-of select="$i"/></label> - <gridline>true</gridline> - </yvalue> - <xsl:if test="$i+$stepid4477040 <= $toid4477040"><xsl:call-template name="for-loop-id4477040"><xsl:with-param name="i" select="$i + $stepid4477040"/><xsl:with-param name="toid4477040" select="$toid4477040"/><xsl:with-param name="stepid4477040" select="$stepid4477040"/><xsl:with-param name="year" select="$year"/><xsl:with-param name="max_contracts" select="$max_contracts"/></xsl:call-template></xsl:if></xsl:template></xsl:stylesheet> Modified: branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp 2006-10-14 07:51:44 UTC (rev 1989) @@ -2,6 +2,7 @@ (defpackage :worldpay-test (:use :cl + :date-calc :extensions :cl-user :cl-interpol @@ -11,7 +12,7 @@ :xhtml-generator :cxml :puri - :mime + #+(or) :mime :acl-compat.socket :acl-compat.mp :bknr.web Added: branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp 2006-10-14 07:51:44 UTC (rev 1989) @@ -0,0 +1,99 @@ + +(in-package :worldpay-test) + +(enable-interpol-syntax) + +(defclass reports-xml-handler (prefix-handler) + ()) + +(defvar *report-generators* (make-hash-table)) +(defvar *contracts-to-process*) +(defvar *year*) +(defvar *month-names* '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) + +(defmacro defreport (name arguments &body body) + `(setf (gethash ',name *report-generators*) (lambda (,@arguments) ,@body))) + +(defun contract-year (contract) + (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract)) + year)) + +(defmethod handle ((handler reports-xml-handler) req) + (with-xml-response req + (destructuring-bind (name *year* &rest arguments) (decoded-handler-path handler req) + (setf *year* (parse-integer *year*)) + (let ((*contracts-to-process* (sort (remove-if (lambda (contract) + (or (not (contract-paidp contract)) + (and *year* + (not (eql *year* (contract-year contract)))))) + (class-instances 'contract)) + #'< :key #'contract-date))) + (setf name (intern (string-upcase name) :worldpay-test)) + (apply (or (gethash name *report-generators*) + (error "invalid report name ~A" name)) + arguments))))) + + +(defreport all-contracts () + (dolist (contract *contracts-to-process*) + (with-element "contract" + (attribute "date-time" (format-date-time (contract-date contract) :xml-style t)) + (attribute "country" (sponsor-country (contract-sponsor contract))) + (attribute "sqm-count" (length (contract-m2s contract)))))) + +(defun week-of-contract (contract) + "Return Week key (YYYY-WW) for given contract." + (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract)) + (multiple-value-bind (week-no week-year) + (week-of-year year month date) + (when (and (> week-no 50) + (eql month 1)) + ;; If the date falls within the last week of the previous + ;; year, we put it into the first week of the current year in + ;; order to simplify graphics drawing. + (setf week-no 1)) + (format nil "~A-~A" week-year week-no)))) + +(defun week-first-yday (contract) + "Return the day-of year of the first day of the contract's date" + (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract)) + (max 0 (- (day-of-year year month date) (day-of-week year month date))))) + +(defreport contracts-by-week () + (dolist (week-contracts (group-on *contracts-to-process* + :test #'equal + :key #'week-of-contract)) + (with-element "week" + (attribute "week-first-yday" (week-first-yday (first (cdr week-contracts)))) + (attribute "key" (first week-contracts)) + (attribute "contracts" (length (cdr week-contracts))) + (attribute "sqms" (apply #'+ (mapcar (lambda (contract) (length (contract-m2s contract))) (cdr week-contracts)))))) + (dotimes (month 12) + (with-element "month" + (attribute "number" month) + (attribute "name" (nth month *month-names*)) + (attribute "start-yday" (1- (day-of-year *year* (1+ month) 1)))))) + +(defreport contract-sizes () + (let ((contract-sizes (make-hash-table :test #'equal)) + (thresholds '(1 10 30 100 10000000))) + (dolist (threshold thresholds) + (setf (gethash threshold contract-sizes) 0)) + (dolist (contract *contracts-to-process*) + (dolist (threshold thresholds) + (when (<= (length (contract-m2s contract)) threshold) + (incf (gethash threshold contract-sizes)) + (return)))) + (dolist (threshold thresholds) + (with-element "contracts" + (attribute "threshold" threshold) + (attribute "count" (gethash threshold contract-sizes)))))) + +(defreport contract-countries () + (dolist (country-contracts (sort (group-on *contracts-to-process* + :test #'equal + :key (lambda (contract) (sponsor-country (contract-sponsor contract)))) + #'> :key (lambda (entry) (length (cdr entry))))) + (with-element "country" + (attribute "code" (car country-contracts)) + (attribute "contracts" (length (cdr country-contracts)))))) \ No newline at end of file Added: branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp 2006-10-14 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp 2006-10-14 07:51:44 UTC (rev 1989) @@ -0,0 +1,21 @@ +(in-package :worldpay-test) + +(defmethod rss-item-channel ((item news-item)) + "news") + +(defmethod rss-item-published ((item news-item)) + (format t "Language: ~A~%" (current-website-language)) + t) + +(defmethod rss-item-title ((item news-item)) + (news-item-title item (current-website-language))) + +(defmethod rss-item-description ((item news-item)) + (news-item-text item (current-website-language))) + +(defmethod rss-item-link ((item news-item)) + (format nil "http://createrainforest.org/~A/news-extern/~A" (current-website-language) (store-object-id item))) + +(defmethod rss-item-guid ((item news-item)) + (format nil "http://createrainforest.org/~A/news-extern/~A" (current-website-language) (store-object-id item))) + 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 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd 2006-10-14 07:51:44 UTC (rev 1989) @@ -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 "reports-xml-handler" :depends-on ("boi-handlers")) (:file "sponsor-handlers" :depends-on ("web-utils")) (:file "news-handlers" :depends-on ("web-utils")) (:file "allocation-area-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 07:07:33 UTC (rev 1988) +++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-14 07:51:44 UTC (rev 1989) @@ -185,6 +185,7 @@ ("/edit-poi-image" edit-poi-image-handler) ("/edit-sponsor" edit-sponsor-handler) ("/contract" contract-handler) + ("/reports-xml" reports-xml-handler) ("/complete-transfer" complete-transfer-handler) ("/edit-news" edit-news-handler) ("/make-poi" make-poi-handler)

1 0