July 2008 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] hans changed trunk/clixdoc/clixdoc.xsl
by BKNR Commits 19 Jul '08

19 Jul '08

Revision: 3513 Author: hans URL: http://bknr.net/trac/changeset/3513 Insert title and short-description into HTML. U trunk/clixdoc/clixdoc.xsl Modified: trunk/clixdoc/clixdoc.xsl =================================================================== --- trunk/clixdoc/clixdoc.xsl 2008-07-19 06:08:15 UTC (rev 3512) +++ trunk/clixdoc/clixdoc.xsl 2008-07-19 06:09:45 UTC (rev 3513) @@ -42,6 +42,9 @@ </html> </xsl:template> + <xsl:template match="clix:title"/> + <xsl:template match="clix:short-description"/> + <xsl:template match="clix:function"> <p> <xsl:choose>

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/
by BKNR Commits 19 Jul '08

19 Jul '08

Revision: 3512 Author: hans URL: http://bknr.net/trac/changeset/3512 Cut corners transparently instead of requiring a background color. U trunk/projects/quickhoney/src/imageproc.lisp U trunk/projects/quickhoney/website/static/javascript.js Modified: trunk/projects/quickhoney/src/imageproc.lisp =================================================================== --- trunk/projects/quickhoney/src/imageproc.lisp 2008-07-19 06:05:56 UTC (rev 3511) +++ trunk/projects/quickhoney/src/imageproc.lisp 2008-07-19 06:08:15 UTC (rev 3512) @@ -3,26 +3,55 @@ (defparameter *button-size* 208) (defparameter *big-button-size* 318) -(defun corner-image (color &key (image *default-image*) - (radius (/ (max (image-width image) (image-height image)) 40))) - (let* ((radius (floor radius)) - (diameter (+ 1 radius radius)) - (other-color (destructuring-bind (red green blue alpha) (color-components color :image image) - (declare (ignore alpha)) - (logxor #xffffff (+ red (ash green 8) (ash blue 16)))))) - (assert (and (>= (image-width image) diameter) - (>= (image-height image) diameter))) - (with-image (circle diameter diameter t) - (fill-image 0 0 :color color :image circle) - (draw-filled-circle radius radius radius :color other-color :image circle) - (do-rows (y circle) - (do-pixels-in-row (x) - (when (eql (raw-pixel) color) - (set-pixel (if (< x radius) x (+ (- (image-width image) diameter) x)) - (if (< y radius) y (+ (- (image-height image) diameter) y)) - :image image :color color))))))) +(defun corner-cutout-coords (image-width image-height radius) + "Return a list of coordinates that need to be made transparent or + colored in background color to get a rounded corner effect. + IMAGE-WIDTH and IMAGE-HEIGHT are the dimensions of the image, RADIUS + is the desired corner rounding radius. The list of coordinates that + is returned is ordered by row and column so that DO-ROWS and + DO-PIXELS-IN-ROW can be used to iterate over the image and pop + coordinate pairs off the front of the list at the same time." + (let ((radius (floor radius)) + (diameter (+ 1 radius radius)) + coords) + (assert (and (>= image-width diameter) + (>= image-height diameter))) + (with-image (circle diameter diameter) + (let ((white (allocate-color 255 255 255 :image circle)) + (black (allocate-color 0 0 0 :image circle))) + (fill-image 0 0 :color white :image circle) + (draw-filled-circle radius radius radius :color black :image circle) + (do-rows (y circle) + (do-pixels-in-row (x) + (when (eql (raw-pixel) white) + (push (list (if (< x radius) x (+ (- image-width diameter) x)) + (if (< y radius) y (+ (- image-height diameter) y))) + coords)))))) + (nreverse coords))) +(defun corner-image (&key (image *default-image*) + (radius (/ (max (image-width image) (image-height image)) 40))) + (with-default-image (image) + (setf (save-alpha-p) t) + (let ((transparent-color (if (true-color-p) #x7f000000 + (or (transparent-color) + (allocate-color 255 255 255 :alpha 127) + (error "can't allocate transparent color for button"))))) + (setf (transparent-color) transparent-color) + (let ((coords (corner-cutout-coords (image-width) (image-height) radius))) + (destructuring-bind (x-tx y-tx) (car coords) + (do-rows (y) + (do-pixels-in-row (x) + (when (and (eql x x-tx) + (eql y y-tx)) + (setf (raw-pixel) transparent-color) + (when (cdr coords) + (setf coords (cdr coords) + x-tx (caar coords) + y-tx (cadar coords))))))))))) + (define-imageproc-handler cutout-button (input-image &optional keyword (background-color "ffffff") (button-size "208") (radius "8")) + (declare (ignore background-color)) (let* ((button-size (parse-integer button-size)) (button-image (create-image button-size button-size t)) (square-size (min (image-width input-image) (image-height input-image))) @@ -44,7 +73,7 @@ 0 0 0 0 (image-width type-image) (image-height type-image))))) - (corner-image (parse-color background-color :image button-image) :image button-image :radius (parse-integer radius)) + (corner-image :image button-image :radius (parse-integer radius)) button-image)) (define-imageproc-handler center-thumbnail (input-image width height) Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-19 06:05:56 UTC (rev 3511) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-19 06:08:15 UTC (rev 3512) @@ -207,6 +207,47 @@ $("edit_client_select").innerHTML = make_clients_selector('edit_client'); } +/* news */ + +function loadXMLDoc(fname) +{ + var xmlDoc; + + // code for IE + if (window.ActiveXObject) { + xmlDoc = new ActiveXObject("Microsoft.XMLDOM"); + } + else if (document.implementation + && document.implementation.createDocument) { + // code for Mozilla, Firefox, Opera, etc. + xmlDoc = document.implementation.createDocument("","",null); + } else { + alert('Your browser cannot handle this script'); + } + xmlDoc.async = false; + xmlDoc.load(fname); + + return xmlDoc; +} + +function xstlTransformDocumentToElement(document, stylesheet, elementId) +{ + xml = loadXMLDoc(document); + xsl = loadXMLDoc(stylesheet); + if (window.ActiveXObject) { + // code for IE + ex = xml.transformNode(xsl); + document.getElementById(elementId).innerHTML = ex; + } else if (document.implementation + && document.implementation.createDocument) { + // code for Mozilla, Firefox, Opera, etc. + xsltProcessor = new XSLTProcessor(); + xsltProcessor.importStylesheet(xsl); + resultDocument = xsltProcessor.transformToFragment(xml,document); + document.getElementById(elementId).appendChild(resultDocument); + } +} + /* image database */ var current_directory;

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/
by BKNR Commits 19 Jul '08

19 Jul '08

Revision: 3511 Author: hans URL: http://bknr.net/trac/changeset/3511 Tweaks to make RSS channel controllable by query parameters. U trunk/bknr/web/src/packages.lisp U trunk/bknr/web/src/rss/rss.lisp Modified: trunk/bknr/web/src/packages.lisp =================================================================== --- trunk/bknr/web/src/packages.lisp 2008-07-18 21:34:47 UTC (rev 3510) +++ trunk/bknr/web/src/packages.lisp 2008-07-19 06:05:56 UTC (rev 3511) @@ -19,7 +19,7 @@ #:start-cron)) (defpackage :bknr.rss - (:use :cl :cl-user :cl-ppcre :bknr.utils :bknr.xml :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml) + (:use :cl :cl-user :cl-ppcre :bknr.utils :bknr.xml :puri :hunchentoot :bknr.datastore :bknr.indices :cxml) (:export ;; channel #:rss-channel Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-18 21:34:47 UTC (rev 3510) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-19 06:05:56 UTC (rev 3511) @@ -111,11 +111,14 @@ (defgeneric rss-channel-items (channel) (:documentation "Return all non-expired items in channel.") (:method ((channel rss-channel)) - (let ((expiry-time (- (get-universal-time) (rss-channel-max-item-age channel)))) - (remove-if (lambda (item) (or (object-destroyed-p item) - (< (rss-item-pub-date item) expiry-time))) - (slot-value channel 'items))))) - + (let ((days (when (boundp 'hunchentoot:*request*) (bknr.web:query-param "days")))) + (let ((expiry-time (- (get-universal-time) (if days + (* 60 60 25 (parse-integer days)) + (rss-channel-max-item-age channel))))) + (remove-if (lambda (item) (or (object-destroyed-p item) + (< (rss-item-pub-date item) expiry-time))) + (slot-value channel 'items)))))) + (deftransaction rss-channel-cleanup (channel) "Remove expired items from the items list. Can be used to reduce the memory footprint of very high volume channels."

1 0

[bknr-cvs] hans changed trunk/projects/pch/src/pch.erl
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3510 Author: hans URL: http://bknr.net/trac/changeset/3510 Simple in-memory cache implemented. U trunk/projects/pch/src/pch.erl Modified: trunk/projects/pch/src/pch.erl =================================================================== --- trunk/projects/pch/src/pch.erl 2008-07-18 16:29:16 UTC (rev 3509) +++ trunk/projects/pch/src/pch.erl 2008-07-18 21:34:47 UTC (rev 3510) @@ -2,49 +2,40 @@ %%% http://www.rsaccon.com/2007/09/mochiweb-erlang-based-webserver-toolkit.html -module(pch). --export([start/0, loop/1, stop/0]). +-export([start/0, loop/2, stop/0]). -define(DEFAULTS, [{name, ?MODULE}, {port, 9888}]). start() -> - Loop = fun (Req) -> ?MODULE:loop(Req) end, + Cache = ets:new(table, [set, public]), + Loop = fun (Req) -> ?MODULE:loop(Req, Cache) end, mochiweb_http:start([{loop, Loop} | ?DEFAULTS]). stop() -> mochiweb_http:stop(?MODULE). -backend_request(Req) -> +fetch_from_backend(Path) -> {ok, {{_Version, 200, _ReasonPhrase}, Headers, Body}} = - http:request("http://test.createrainforest.org" ++ Req:get(path)), - Req:respond({200, Headers, Body}). + http:request("http://test.createrainforest.org" ++ Path), + {ok, Headers, Body}. -loop(Req) -> - "/" ++ Path = Req:get(path), +backend_request(Req, Cache) -> + Path = Req:get(path), + case ets:lookup(Cache, Path) of + [{Path, Headers, Body}] -> + io:format("cache HIT for ~p~n", [Path]), + Req:respond({200, Headers, Body}); + _ -> + io:format("cache MISS for ~p~n", [Path]), + {ok, Headers, Body} = fetch_from_backend(Path), + ets:insert(Cache, {Path, Headers, Body}), + Req:respond({200, Headers, Body}) + end. + +loop(Req, Cache) -> case Req:get(method) of - M when M =:= 'GET'; M =:= 'HEAD' -> - case Path of - "timer" -> - Response = Req:ok({"text/plain", chunked}), - timer(Response); - "static" -> - Req:ok({"text/plain", "static response"}); - "nodes" -> - Req:ok({"text/plain", - io_lib:format("~p~n", [nodes()])}); - "dump" -> - Req:ok({"text/plain", - io_lib:format("~p~n", [Req:dump()])}); -%% _ -> -%% Req:serve_file(Path) - _ -> - backend_request(Req) - end; + M when M =:= 'GET' -> + backend_request(Req, Cache); _ -> Req:respond({501, [], ""}) end. - -timer(Req) -> - Req:write_chunk(io_lib:format("The time is: ~p~n", - [calendar:local_time()])), - timer:sleep(1000), - timer(Req).

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3509 Author: hans URL: http://bknr.net/trac/changeset/3509 Already works a little. U trunk/projects/pch/src/pch.erl _U trunk/thirdparty/mochiweb/doc/ _U trunk/thirdparty/mochiweb/ebin/ Modified: trunk/projects/pch/src/pch.erl =================================================================== --- trunk/projects/pch/src/pch.erl 2008-07-18 16:11:06 UTC (rev 3508) +++ trunk/projects/pch/src/pch.erl 2008-07-18 16:29:16 UTC (rev 3509) @@ -2,20 +2,23 @@ %%% http://www.rsaccon.com/2007/09/mochiweb-erlang-based-webserver-toolkit.html -module(pch). --export([start/0, loop/2, stop/0]). +-export([start/0, loop/1, stop/0]). -define(DEFAULTS, [{name, ?MODULE}, - {port, 9952}]). + {port, 9888}]). start() -> - DocRoot = filename:dirname(filename:dirname(code:which(?MODULE))), - code:add_patha(filename:join([DocRoot, "mochiweb-c4", "ebin"])), - Loop = fun (Req) -> ?MODULE:loop(Req, DocRoot) end, + Loop = fun (Req) -> ?MODULE:loop(Req) end, mochiweb_http:start([{loop, Loop} | ?DEFAULTS]). stop() -> mochiweb_http:stop(?MODULE). -loop(Req, DocRoot) -> +backend_request(Req) -> + {ok, {{_Version, 200, _ReasonPhrase}, Headers, Body}} = + http:request("http://test.createrainforest.org" ++ Req:get(path)), + Req:respond({200, Headers, Body}). + +loop(Req) -> "/" ++ Path = Req:get(path), case Req:get(method) of M when M =:= 'GET'; M =:= 'HEAD' -> @@ -31,8 +34,10 @@ "dump" -> Req:ok({"text/plain", io_lib:format("~p~n", [Req:dump()])}); +%% _ -> +%% Req:serve_file(Path) _ -> - Req:serve_file(Path, DocRoot) + backend_request(Req) end; _ -> Req:respond({501, [], ""}) Property changes on: trunk/thirdparty/mochiweb/doc ___________________________________________________________________ Name: svn:ignore + *.html Property changes on: trunk/thirdparty/mochiweb/ebin ___________________________________________________________________ Name: svn:ignore + *.beam *.app

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3508 Author: ksprotte URL: http://bknr.net/trac/changeset/3508 contract-tree nodes are no more transparent if there are on the last layer U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-18 16:08:27 UTC (rev 3507) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-18 16:11:06 UTC (rev 3508) @@ -241,7 +241,9 @@ (labels ((find-contract-color (contract) (destructuring-bind (r g b) (contract-color contract) - (cl-gd:find-color r g b :alpha 40)))) + (cl-gd:find-color r g b :alpha (if (node-has-children-p node) + 40 + 0))))) (let ((box (geo-box node)) (image-size *contract-tree-images-size*)) ;; (warn "will update image for ~a" node)

1 0

[bknr-cvs] hans changed trunk/projects/pch/
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3507 Author: hans URL: http://bknr.net/trac/changeset/3507 Create new frontend project: Pontificia Cohors Helvetica A trunk/projects/pch/ A trunk/projects/pch/src/ A trunk/projects/pch/src/pch.erl Added: trunk/projects/pch/src/pch.erl =================================================================== --- trunk/projects/pch/src/pch.erl (rev 0) +++ trunk/projects/pch/src/pch.erl 2008-07-18 16:08:27 UTC (rev 3507) @@ -0,0 +1,45 @@ +%%% from +%%% http://www.rsaccon.com/2007/09/mochiweb-erlang-based-webserver-toolkit.html + +-module(pch). +-export([start/0, loop/2, stop/0]). +-define(DEFAULTS, [{name, ?MODULE}, + {port, 9952}]). + +start() -> + DocRoot = filename:dirname(filename:dirname(code:which(?MODULE))), + code:add_patha(filename:join([DocRoot, "mochiweb-c4", "ebin"])), + Loop = fun (Req) -> ?MODULE:loop(Req, DocRoot) end, + mochiweb_http:start([{loop, Loop} | ?DEFAULTS]). + +stop() -> + mochiweb_http:stop(?MODULE). + +loop(Req, DocRoot) -> + "/" ++ Path = Req:get(path), + case Req:get(method) of + M when M =:= 'GET'; M =:= 'HEAD' -> + case Path of + "timer" -> + Response = Req:ok({"text/plain", chunked}), + timer(Response); + "static" -> + Req:ok({"text/plain", "static response"}); + "nodes" -> + Req:ok({"text/plain", + io_lib:format("~p~n", [nodes()])}); + "dump" -> + Req:ok({"text/plain", + io_lib:format("~p~n", [Req:dump()])}); + _ -> + Req:serve_file(Path, DocRoot) + end; + _ -> + Req:respond({501, [], ""}) + end. + +timer(Req) -> + Req:write_chunk(io_lib:format("The time is: ~p~n", + [calendar:local_time()])), + timer:sleep(1000), + timer(Req).

1 0

[bknr-cvs] hans changed trunk/thirdparty/mochiweb/
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3506 Author: hans URL: http://bknr.net/trac/changeset/3506 import mochiweb A trunk/thirdparty/mochiweb/ A trunk/thirdparty/mochiweb/LICENSE A trunk/thirdparty/mochiweb/Makefile A trunk/thirdparty/mochiweb/README A trunk/thirdparty/mochiweb/deps/ A trunk/thirdparty/mochiweb/doc/ A trunk/thirdparty/mochiweb/ebin/ A trunk/thirdparty/mochiweb/include/ A trunk/thirdparty/mochiweb/priv/ A trunk/thirdparty/mochiweb/priv/skel/ A trunk/thirdparty/mochiweb/priv/skel/Makefile A trunk/thirdparty/mochiweb/priv/skel/deps/ A trunk/thirdparty/mochiweb/priv/skel/doc/ A trunk/thirdparty/mochiweb/priv/skel/ebin/ A trunk/thirdparty/mochiweb/priv/skel/include/ A trunk/thirdparty/mochiweb/priv/skel/priv/ A trunk/thirdparty/mochiweb/priv/skel/priv/www/ A trunk/thirdparty/mochiweb/priv/skel/priv/www/index.html A trunk/thirdparty/mochiweb/priv/skel/src/ A trunk/thirdparty/mochiweb/priv/skel/src/Makefile A trunk/thirdparty/mochiweb/priv/skel/src/skel.app A trunk/thirdparty/mochiweb/priv/skel/src/skel.erl A trunk/thirdparty/mochiweb/priv/skel/src/skel.hrl A trunk/thirdparty/mochiweb/priv/skel/src/skel_app.erl A trunk/thirdparty/mochiweb/priv/skel/src/skel_deps.erl A trunk/thirdparty/mochiweb/priv/skel/src/skel_sup.erl A trunk/thirdparty/mochiweb/priv/skel/src/skel_web.erl A trunk/thirdparty/mochiweb/priv/skel/start-dev.sh A trunk/thirdparty/mochiweb/priv/skel/start.sh A trunk/thirdparty/mochiweb/priv/skel/support/ A trunk/thirdparty/mochiweb/priv/skel/support/include.mk A trunk/thirdparty/mochiweb/scripts/ A trunk/thirdparty/mochiweb/scripts/new_mochiweb.erl A trunk/thirdparty/mochiweb/src/ A trunk/thirdparty/mochiweb/src/Makefile A trunk/thirdparty/mochiweb/src/mochifmt.erl A trunk/thirdparty/mochiweb/src/mochifmt_records.erl A trunk/thirdparty/mochiweb/src/mochifmt_std.erl A trunk/thirdparty/mochiweb/src/mochihex.erl A trunk/thirdparty/mochiweb/src/mochijson.erl A trunk/thirdparty/mochiweb/src/mochijson2.erl A trunk/thirdparty/mochiweb/src/mochinum.erl A trunk/thirdparty/mochiweb/src/mochiweb.app A trunk/thirdparty/mochiweb/src/mochiweb.erl A trunk/thirdparty/mochiweb/src/mochiweb_app.erl A trunk/thirdparty/mochiweb/src/mochiweb_charref.erl A trunk/thirdparty/mochiweb/src/mochiweb_cookies.erl A trunk/thirdparty/mochiweb/src/mochiweb_echo.erl A trunk/thirdparty/mochiweb/src/mochiweb_headers.erl A trunk/thirdparty/mochiweb/src/mochiweb_html.erl A trunk/thirdparty/mochiweb/src/mochiweb_http.erl A trunk/thirdparty/mochiweb/src/mochiweb_multipart.erl A trunk/thirdparty/mochiweb/src/mochiweb_request.erl A trunk/thirdparty/mochiweb/src/mochiweb_response.erl A trunk/thirdparty/mochiweb/src/mochiweb_skel.erl A trunk/thirdparty/mochiweb/src/mochiweb_socket_server.erl A trunk/thirdparty/mochiweb/src/mochiweb_sup.erl A trunk/thirdparty/mochiweb/src/mochiweb_util.erl A trunk/thirdparty/mochiweb/src/reloader.erl A trunk/thirdparty/mochiweb/support/ A trunk/thirdparty/mochiweb/support/include.mk Change set too large, please see URL above

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3505 Author: ksprotte URL: http://bknr.net/trac/changeset/3505 removed kml-req-count that was used for debugging U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-18 14:28:25 UTC (rev 3504) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-18 15:19:08 UTC (rev 3505) @@ -5,9 +5,7 @@ ((name :allocation :class :initform 'contract-node) (timestamp :accessor timestamp :initform 0) ; timestamp initially "very old" (placemark-contracts :initform nil :accessor placemark-contracts) - (image :initform nil :accessor image) - (kml-req-count :initform 0 :accessor kml-req-count) - (image-req-count :initform 0 :accessor image-req-count))) + (image :initform nil :accessor image))) (defun contract-node-invalidate-timestamp (node) (let ((image (contract-node-find-corresponding-store-image node))) @@ -155,8 +153,7 @@ :root-element "kml") (with-query-params ((lang "en") (path) (rmcpath) (rmcid)) - (handle-if-node-modified - (incf (kml-req-count node)) + (handle-if-node-modified (setf (hunchentoot:header-out :last-modified) (hunchentoot:rfc-1123-date (timestamp node))) (let* ((lod (node-lod node))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/kml-
by BKNR Commits 18 Jul '08

18 Jul '08

Revision: 3504 Author: ksprotte URL: http://bknr.net/trac/changeset/3504 new style option for kml-network-links: :hide-children t U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/kml-utils.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-18 13:29:12 UTC (rev 3503) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-18 14:28:25 UTC (rev 3504) @@ -83,11 +83,18 @@ (with-element "range" (text "1134.262777389377")) (with-element "tilt" (text "0")) (with-element "heading" (text "1.391362238653075"))) - (dolist (sat-layer (class-instances 'sat-layer)) - (kml-network-link (format nil "http://~a/sat-root-kml?name=~A" (website-host) (name sat-layer)) - :rect (geo-box-rectangle *m2-geo-box*) - :lod '(:min 0 :max -1) - :name (dictionary-entry (princ-to-string (name sat-layer)) lang))) + (with-element "Folder" + (attribute "name" "Sat-Images") + (attribute "open" "1") + (with-element "Style" + (with-element "ListStyle" + (with-element "listItemType" (text "radioFolder")))) + (dolist (sat-layer (class-instances 'sat-layer)) + (kml-network-link (format nil "http://~a/sat-root-kml?name=~A" (website-host) (name sat-layer)) + :rect (geo-box-rectangle *m2-geo-box*) + :lod '(:min 0 :max -1) + :name (dictionary-entry (princ-to-string (name sat-layer)) lang) + :hide-children t))) (let ((href (if (not contract) (format nil "http://~a/contract-tree-kml?lang=~A" (website-host) lang) (let* ((node (find-contract-node *contract-tree* contract)) @@ -98,13 +105,16 @@ (kml-network-link href :rect (geo-box-rectangle (geo-box *contract-tree*)) :lod (node-lod *contract-tree*) - :name (dictionary-entry "Squaremetre Area" lang))) + :name (dictionary-entry "Squaremetre Area" lang) + :hide-children t)) (kml-network-link (format nil "http://~a/poi-kml-all?lang=~A" (website-host) lang) :name (dictionary-entry "POIs" lang) :rect (make-rectangle :x 0 :y 0 :width +width+ :height +width+) - :lod '(:min 0 :max -1)) + :lod '(:min 0 :max -1) + :hide-children t) (kml-network-link (format nil "http://~a/country-stats?lang=~A" (website-host) lang) - :name (dictionary-entry "Country-Stats" lang))))))) + :name (dictionary-entry "Country-Stats" lang) + :hide-children t)))))) (defmethod handle-object ((handler kml-root-handler) (object sponsor)) (write-root-kml handler object)) Modified: trunk/projects/bos/web/kml-utils.lisp =================================================================== --- trunk/projects/bos/web/kml-utils.lisp 2008-07-18 13:29:12 UTC (rev 3503) +++ trunk/projects/bos/web/kml-utils.lisp 2008-07-18 14:28:25 UTC (rev 3504) @@ -267,11 +267,20 @@ ;; (puri:render-uri href out)))) ;; (kml-link string))) + +(defun kml-hide-children-style () + (with-element "Style" + (with-element "ListStyle" + (with-element "listItemType" (text "checkHideChildren")) + (with-element "bgColor" (text "00ffffff"))))) + (defun kml-network-link (href &key rect lod name http-query - fly-to-view) + fly-to-view hide-children) (with-element "NetworkLink" (when name (with-element "name" (text name))) (when rect (kml-region rect lod)) + (when hide-children + (kml-hide-children-style)) (when fly-to-view (with-element "flyToView" (text "1"))) (kml-link href)))

1 0