phoros-js.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18 (in-package :phoros)
  19
  20 (hunchentoot:define-easy-handler (phoros.js) ()
  21   "Serve some Javascript."
  22   (when (hunchentoot:session-value 'authenticated-p)
  23     (ps*
  24      '(progn
  25        (setf debug-info (@ *open-layers *console info))
  26
  27        (defmacro inner-html-with-id (id)
  28          "innerHTML of element with id=\"id\"."
  29          `(chain document (get-element-by-id ,id) inner-h-t-m-l))
  30
  31        (defmacro value-with-id (id)
  32          "Value of element with id=\"id\"."
  33          `(chain document (get-element-by-id ,id) value))
  34
  35        (defmacro checkbox-status-with-id (id)
  36          "Whether checkbox with id=\"id\" is checked or not."
  37          `(chain document (get-element-by-id ,id) checked))
  38
  39        (defvar *help-topics*
  40          (create
  41           :user-role
  42           (who-ps-html
  43            (:p "User role.  \"Read\" can't write or modify anything.
  44            \"Write\" may write user points and delete their own
  45            ones. \"Admin\" may write user points and delete points
  46            written by others."))
  47           :presentation-project-name
  48           (who-ps-html
  49            (:p "Presentation project name."))
  50           :presentation-project-emptiness
  51           (who-ps-html
  52            (:p "This presentation project is empty.  You can't do much
  53            with it."))
  54           :phoros-version
  55           (who-ps-html
  56            (:p "Phoros version.")
  57            (:p "In a version string A.B.C, changes in A denote
  58            incompatible changes in data (you can't access a database
  59            set up by a different version of Phoros); changes in B mean
  60            user-visible changes in feature set; changes in C denote
  61            bug fixes and minor improvements."))
  62           :h2-controls
  63           (who-ps-html
  64            (:p "Current action."))
  65           :multiple-points-phoros-controls
  66           (who-ps-html
  67            (:p "Try reading the text under mouse pointer."))
  68           :finish-point-button
  69           (who-ps-html
  70            (:p "Store user point with its attribute,
  71            numeric-description, description, and auxiliary data into
  72            database."))
  73           :delete-point-button
  74           (who-ps-html
  75            (:p "Delete current point."))
  76           :download-user-points-button
  77           (who-ps-html
  78            (:p "Download all user points as GeoJSON-fomatted text
  79            file.  Do this regularly if you don't want to lose your
  80            work due to server crashes or major Phoros updates.")
  81            (:p "Points saved this way can be fed back into your
  82            project using the command line interface (on server or on
  83            any other host where the database is reachable)."))
  84           :point-attribute
  85           (who-ps-html
  86            (:h3 "\"attribute\"")
  87            (:p "The standard ones, polygon, polyline, and solitary are
  88            rendered as asterisk, square, and triangle respectively.
  89            Anything else is rendered as an X."))
  90           :point-description
  91           (who-ps-html
  92            (:h3 "\"description\"")
  93            (:p "Optional textual description of the set of user points
  94            the current point belongs to."))
  95           :point-numeric-description
  96           (who-ps-html
  97            (:h3 "\"numeric-description\"")
  98            (:p "Optional description of the current user point.  It is
  99            occasionally used to label representations of this point in
 100            streetmap and in images.")
 101            (:p "If parts of it look like numbers, the leftmost such
 102            part is automatically incremented during first click into
 103            an image."))
 104           :point-creation-date
 105           (who-ps-html
 106            (:p "Creation date of current user point.  Will be updated
 107            when you change this point."))
 108           :include-aux-data
 109           (who-ps-html
 110            (:p "Check this if the user point being created is to
 111            include auxiliary data."))
 112           :aux-point-distance
 113           (who-ps-html
 114            (:p "Select a set of auxiliary data, either by its distance
 115            (in metres) from the current estimated position, or by
 116            clicking its representation in streetmap."))
 117           :aux-data
 118           (who-ps-html
 119            (:p "Auxiliary data connected to this presentation project;
 120            all the numeric values followed by all the text values if
 121            any."))
 122           :creator
 123           (who-ps-html
 124            (:p "Creator of current user point.  Will be updated when
 125            you change this point."))
 126           :remove-work-layers-button
 127           (who-ps-html
 128            (:p "Discard the current, unstored user point or unselect
 129            any selected user points.  Zoom out all images. Keep
 130            the rest of the workspace untouched."))
 131           :blurb-button
 132           (who-ps-html
 133            (:p "View some info about Phoros."))
 134           :logout-button
 135           (who-ps-html
 136            (:p "Finish this session after storing current streetmap
 137            zoom status and your cursor position.")
 138            (:p "Fresh login is required to continue."))
 139           :streetmap
 140           (who-ps-html
 141            (:p "Clicking into the streetmap fetches images which most
 142            probably feature the clicked point.")
 143            (:p "To pan the map, drag the mouse.  To zoom, spin the
 144            mouse wheel, or hold shift down whilst dragging a box, or
 145            double-click (shift double-click for larger zoom steps) a
 146            point of interest."))
 147           :image
 148           (who-ps-html
 149            (:p "Clicking into an image sets or resets the active point
 150            there.  Once a feature is marked by active points in more
 151            than one image, the estimated position is calculated.")
 152            (:p "To pan an image, drag the mouse.  To zoom, spin the
 153            mouse wheel, or hold shift down whilst dragging a box, or
 154            double-click (shift double-click for larger zoom steps) a
 155            point of interest."))
 156           ol-Control-Pan-West-Item-Inactive
 157           (who-ps-html
 158            (:p "Move viewport left."))
 159           ol-Control-Pan-East-Item-Inactive
 160           (who-ps-html
 161            (:p "Move viewport right."))
 162           ol-Control-Pan-North-Item-Inactive
 163           (who-ps-html
 164            (:p "Move viewport up."))
 165           ol-Control-Pan-South-Item-Inactive
 166           (who-ps-html
 167            (:p "Move viewport down."))
 168           ol-Control-Zoom-In-Item-Inactive
 169           (who-ps-html
 170            (:p "Zoom in."))
 171           ol-Control-Zoom-Out-Item-Inactive
 172           (who-ps-html
 173            (:p "Zoom out."))
 174           streetmap-Zoom-To-Max-Extent-Item-Inactive
 175           (who-ps-html
 176            (:p "Zoom to the extent of presentation project."))
 177           ol-Control-Zoom-To-Max-Extent-Item-Inactive
 178           (who-ps-html
 179            (:p "Zoom out completely, restoring the original view."))
 180           :zoom-images-to-max-extent
 181           (who-ps-html
 182            (:p "Zoom all images out completely, restoring the original
 183            view."))
 184           :no-footprints-p
 185           (who-ps-html
 186            (:p "I haven't been able to display a set of images that
 187            cover a common area because I couldn't find the necessary
 188            information.  As a fallback, I'm displaying a set of images
 189            with points of view close to the point you selected.")
 190            (:p "The server is probably trying to remedy this problem
 191            but this may take some time."))
 192           :auto-zoom
 193           (who-ps-html
 194            (:p "Check this to automatically zoom into images once they
 195            get an estimated position."))
 196           :walk-mode
 197           (who-ps-html
 198            (:p "Check this to snap your current position onto a line
 199            along points of auxiliary data, and to keep streetmap
 200            centered around current position."))
 201           :decrease-step-size
 202           (who-ps-html
 203            (:p "Decrease step size.  Double-click to decrease harder."))
 204           :step-size
 205           (who-ps-html
 206            (:p "Step size in metres.  Click to increase; double-click
 207            to increase harder."))
 208           :increase-step-size
 209           (who-ps-html
 210            (:p "Increase step size.  Double-click to increase harder."))
 211           :step-button
 212           (who-ps-html
 213            (:p "Move your position by one step on a line along points
 214            of auxiliary data.  Double-click to change direction."))
 215           :image-layer-switcher
 216           (who-ps-html
 217            (:p "Toggle display of image."))
 218           :image-usable
 219           (who-ps-html
 220            (:p "No photogrammetric survey possible as there isn't any
 221            usable calibration data available for this image.")
 222            (:p "This means no image footprints can be calculated
 223            either which prevents me from selecting images covering a
 224            common area."))
 225           :image-trigger-time
 226           (who-ps-html
 227            (:p "Time this image was taken."))
 228           base-layers-div
 229           (who-ps-html
 230            (:p "Choose a background streetmap."))
 231           data-layers-div
 232           (who-ps-html
 233            (:p "Toggle visibility of data layers."))
 234           :streetmap-overview
 235           (who-ps-html
 236            (:p "Click to re-center streetmap, or drag the red
 237            rectangle."))
 238           :streetmap-mouse-position
 239           (who-ps-html
 240            (:p "Cursor position in geographic coordinates when cursor
 241            is in streetmap."))
 242           :h2-help
 243           (who-ps-html
 244            (:p "Hints on Phoros' displays and controls are shown here
 245            while hovering over the respective elements."))))
 246
 247        (defun add-help-topic (topic element)
 248          "Add mouse events to DOM element that initiate display of a
 249          help message."
 250          (when element
 251            (setf (@ element onmouseover)
 252                  ((lambda (x)
 253                     (lambda () (show-help x)))
 254                   topic))
 255            (setf (@ element onmouseout) show-help)))
 256
 257        (defun add-help-events ()
 258          "Add mouse events to DOM elements that initiate display of a
 259          help message."
 260          (for-in
 261           (topic *help-topics*)
 262           (add-help-topic topic (chain document (get-element-by-id topic)))
 263           (dolist (element (chain document (get-elements-by-class-name topic)))
 264             (add-help-topic topic element))))
 265
 266        (defun show-help (&optional topic)
 267          "Put text on topic into help-display"
 268          (setf (inner-html-with-id "help-display")
 269                (let ((help-body (getprop *help-topics* topic)))
 270                  (if (undefined help-body)
 271                      ""
 272                      help-body))))
 273
 274        (defvar *click-control*
 275          (chain
 276           *open-layers
 277           (*class
 278            (@ *open-layers *control)
 279            (create
 280             :initialize
 281             (lambda (options)
 282               (chain *open-layers
 283                      *control
 284                      prototype
 285                      initialize
 286                      (apply this arguments))
 287               (setf (@ this handler)
 288                     (new (chain *open-layers
 289                                 *handler
 290                                 (*click this
 291                                         (create
 292                                          :click (@ this trigger)))))))))))
 293
 294        (defvar +unix-epoch+ (lisp *unix-epoch*)
 295          "Seconds between Lisp epoch and UNIX epoch.")
 296        (defvar +geographic+
 297          (new (chain *open-layers (*projection "EPSG:4326"))))
 298        (defvar +spherical-mercator+
 299          (new (chain *open-layers (*projection "EPSG:900913"))))
 300
 301        (defvar +user-name+ (lisp (hunchentoot:session-value 'user-name))
 302          "User's (short) name.")
 303        (defvar +user-role+ (lisp (string-downcase (hunchentoot:session-value
 304                                                    'user-role)))
 305          "User's permissions.")
 306
 307        (defvar +presentation-project-bbox-text+
 308          (lisp (hunchentoot:session-value 'presentation-project-bbox)))
 309
 310        (defvar +presentation-project-bounds+
 311          (chain (new (chain *open-layers
 312                             *bounds
 313                             (from-string
 314                              (or +presentation-project-bbox-text+
 315                                  "-180,-89,180,89"))))
 316                 (transform +geographic+ +spherical-mercator+))
 317          "Bounding box of the entire presentation project.")
 318
 319        (defvar +aux-data-p+
 320          (lisp (hunchentoot:session-value 'aux-data-p)))
 321
 322        (defvar *images* (array) "Collection of the photos currently shown.")
 323
 324        (defvar *streetmap* undefined
 325          "The streetmap shown to the user.")
 326
 327        (defvar *point-attributes-select* undefined
 328          "The HTML element for selecting user point attributes.")
 329
 330        (defvar *aux-point-distance-select* undefined
 331          "The HTML element for selecting one of a few nearest
 332          auxiliary points.")
 333
 334        (defvar *global-position* undefined
 335          "Coordinates of the current estimated position")
 336
 337        (defvar *linestring-step-ratio* 4
 338          "Look for auxiliary points to include into linestring within
 339          a radius of *linestring-step-ratio* multilied by multiplied by
 340          step-size.")
 341
 342        (defvar *current-nearest-aux-point*
 343          (create attributes (create aux-numeric undefined
 344                                     aux-text undefined))
 345          "Attributes of currently selected point of auxiliary data.")
 346
 347        (defvar *bbox-strategy* (@ *open-layers *strategy *bbox*))
 348        (setf (@ *bbox-strategy* prototype ratio) 1.5)
 349        (setf (@ *bbox-strategy* prototype res-factor) 1.5)
 350
 351        (defvar *json-parser* (new (chain *open-layers *format *json*)))
 352
 353        (defvar *geojson-format* (chain *open-layers *format *geo-j-s-o-n))
 354        (setf (@ *geojson-format* prototype ignore-extra-dims)
 355         t)                              ;doesn't handle height anyway
 356        (setf (@ *geojson-format* prototype external-projection)
 357         +geographic+)
 358        (setf (@ *geojson-format* prototype internal-projection)
 359         +geographic+)
 360
 361        (defvar *wkt-parser*
 362          (new (chain *open-layers
 363                      *format
 364                      (*wkt*
 365                       (create external-projection +geographic+
 366                               internal-projection +spherical-mercator+)))))
 367
 368        (defvar *http-protocol* (chain *open-layers *protocol *http*))
 369        (setf (chain *http-protocol* prototype format) (new *geojson-format*))
 370
 371        (defvar *pristine-images-p* t
 372          "T if none of the current images has been clicked into yet.")
 373
 374        (defvar *current-user-point* undefined
 375          "The currently selected user-point.")
 376
 377        (defun write-permission-p (&optional (current-owner +user-name+))
 378          "Nil if current user can't edit stuff created by
 379          current-owner or, without arguments, new stuff."
 380          (or (equal +user-role+ "admin")
 381              (and (equal +user-role+ "write")
 382                   (equal +user-name+ current-owner))))
 383
 384        (defun *image ()
 385          "Anything necessary to deal with a photo."
 386          (setf (@ this map)
 387                (new
 388                 (chain
 389                  *open-layers
 390                  (*map
 391                   (create projection +spherical-mercator+
 392                           all-overlays t
 393                           controls (array (new (chain *open-layers
 394                                                       *control
 395                                                       (*navigation)))))))))
 396          (setf (@ this dummy) false) ;TODO why? (omitting splices map components directly into *image)
 397          )
 398
 399        (setf (@ *image prototype delete-photo)
 400         delete-photo)
 401        (setf (@ *image prototype photop)
 402         photop)
 403        (setf (@ *image prototype show-photo)
 404         show-photo)
 405        (setf (@ *image prototype draw-epipolar-line)
 406         draw-epipolar-line)
 407        (setf (@ *image prototype draw-active-point)
 408         draw-active-point)
 409        (setf (@ *image prototype draw-estimated-positions)
 410         draw-estimated-positions)
 411
 412        (defun photo-path (photo-parameters)
 413          "Create from stuff found in photo-parameters a path for use in
 414          an image url."
 415          (+ "/phoros/lib/photo/" (@ photo-parameters directory) "/"
 416             (@ photo-parameters filename) "/"
 417             (@ photo-parameters byte-position) ".png"
 418             "?mounting-angle=" (@ photo-parameters mounting-angle)
 419             "&bayer-pattern=" (@ photo-parameters bayer-pattern)
 420             "&color-raiser=" (@ photo-parameters color-raiser)))
 421
 422        (defun has-layer-p (map layer-name)
 423          "False if map doesn't have a layer called layer-name."
 424          (chain map (get-layers-by-name layer-name) length))
 425
 426        (defun some-active-point-p ()
 427          "False if no image in *images* has an Active Point."
 428          (loop
 429             for i across *images*
 430             sum (has-layer-p (@ i map) "Active Point")))
 431
 432        (defun remove-layer (map layer-name)
 433          "Destroy layer layer-name in map."
 434          (when (has-layer-p map layer-name)
 435            (chain map (get-layers-by-name layer-name) 0 (destroy))))
 436
 437        (defun remove-any-layers (layer-name)
 438          "Destroy in all *images* and in *streetmap* the layer named layer-name."
 439          (loop
 440             for i across *images* do
 441             (remove-layer (@ i map) layer-name))
 442          (remove-layer *streetmap* layer-name))
 443
 444        (defun reset-controls ()
 445          (reveal-element-with-id "real-phoros-controls")
 446          (hide-element-with-id "multiple-points-phoros-controls")
 447          (disable-element-with-id "finish-point-button")
 448          (disable-element-with-id "delete-point-button")
 449          (disable-element-with-id "remove-work-layers-button")
 450          (setf (inner-html-with-id "h2-controls") "Create Point")
 451          (setf (inner-html-with-id "creator") nil)
 452          (setf (inner-html-with-id "point-creation-date") nil)
 453          (hide-aux-data-choice)
 454          (setf (inner-html-with-id "aux-numeric-list") nil)
 455          (setf (inner-html-with-id "aux-text-list") nil))
 456
 457        (defun disable-streetmap-nearest-aux-points-layer ()
 458          "Get (@ *streetmap* nearest-aux-points-layer) out of the way,
 459          I.e., remove features and disable feature select control so
 460          it won't shadow any other control."
 461          (chain *streetmap* nearest-aux-points-layer (remove-all-features))
 462          (chain *streetmap* nearest-aux-points-select-control (deactivate))
 463          (chain *streetmap* user-points-select-control (activate)))
 464
 465        (defun reset-layers-and-controls ()
 466          "Destroy user-generated layers in *streetmap* and in all
 467          *images*, and put controls into pristine state."
 468          (remove-any-layers "Epipolar Line")
 469          (remove-any-layers "Active Point")
 470          (remove-any-layers "Estimated Position")
 471          (remove-any-layers "User Point")
 472          (chain *streetmap* user-points-select-control (unselect-all))
 473          (disable-streetmap-nearest-aux-points-layer)
 474          (when (and (not (equal undefined *current-user-point*))
 475                     (@ *current-user-point* layer))
 476            (chain *streetmap*
 477                   user-points-select-control
 478                   (unselect *current-user-point*)))
 479          (reset-controls)
 480          (setf *pristine-images-p* t)
 481          (zoom-images-to-max-extent))
 482
 483        (defun enable-element-with-id (id)
 484          "Activate HTML element with id=\"id\"."
 485          (setf (chain document (get-element-by-id id) disabled) nil))
 486
 487        (defun disable-element-with-id (id)
 488          "Grey out HTML element with id=\"id\"."
 489          (setf (chain document (get-element-by-id id) disabled) t))
 490
 491        (defun hide-element-with-id (id)
 492          "Hide HTML element wit id=\"id\"."
 493          (setf (chain document (get-element-by-id id) style display)
 494                "none"))
 495
 496        (defun reveal-element-with-id (id)
 497          "Reveal HTML element wit id=\"id\"."
 498          (setf (chain document (get-element-by-id id) style display)
 499                ""))
 500
 501        (defun hide-aux-data-choice ()
 502          "Disable selector for auxiliary data."
 503          ;;(disable-element-with-id "include-aux-data-p")
 504          (hide-element-with-id "include-aux-data")
 505          (hide-element-with-id "aux-point-distance")
 506          (setf (chain document
 507                       (get-element-by-id "aux-point-distance")
 508                       options
 509                       length)
 510                0))
 511
 512        (defun refresh-layer (layer)
 513          "Have layer re-request and redraw features."
 514          (chain layer (refresh (create :force t))))
 515
 516        (defun present-photos ()
 517          "Handle the response triggered by request-photos-for-point."
 518          (let ((photo-parameters
 519                 (chain *json-parser*
 520                        (read (@ *streetmap*
 521                                 photo-request-response response-text)))))
 522            (loop
 523               for i across *images*
 524               do (chain i (delete-photo)))
 525            (if (@ photo-parameters 0 footprintp)
 526                (hide-element-with-id "no-footprints-p")
 527                (reveal-element-with-id "no-footprints-p"))
 528            (loop
 529               for p across photo-parameters
 530               for i across *images*
 531               do
 532               (setf (@ i photo-parameters) p)
 533               (chain i (show-photo)))))
 534
 535        (defun consolidate-combobox (combobox-id)
 536          "Help faking a combobox: copy selected option into input."
 537          (let ((combobox-select (+ combobox-id "-select"))
 538                (combobox-input (+ combobox-id "-input")))
 539            (setf (value-with-id combobox-input)
 540                  (getprop (chain document
 541                                  (get-element-by-id combobox-select)
 542                                  options)
 543                           (chain document
 544                                  (get-element-by-id combobox-select)
 545                                  selected-index)
 546                           'value))
 547            (chain document
 548                   (get-element-by-id combobox-input)
 549                   (focus))))
 550
 551        (defun unselect-combobox-selection (combobox-id)
 552          "Help faking a combobox: unset selected option so any
 553          selection there will trigger an onchange event."
 554          (let ((combobox-select (+ combobox-id "-select")))
 555            (setf (chain document
 556                         (get-element-by-id combobox-select)
 557                         selected-index)
 558                  -1)))
 559
 560        (defun stuff-combobox (combobox-id values &optional (selection -1))
 561          "Stuff combobox with values.  If selection is a non-negative
 562          integer, select the respective item."
 563          (let ((combobox-select (+ combobox-id "-select"))
 564                (combobox-input (+ combobox-id "-input")))
 565            (setf (chain document
 566                         (get-element-by-id combobox-select)
 567                         options
 568                         length)
 569                  0)
 570            (loop for i in values do
 571                 (setf combobox-item
 572                       (chain document (create-element "option")))
 573                 (setf (@ combobox-item text) i)
 574                 (chain document
 575                        (get-element-by-id combobox-select)
 576                        (add combobox-item null)))
 577            (setf (chain document
 578                         (get-element-by-id combobox-select)
 579                         selected-index)
 580                  selection)
 581            (consolidate-combobox combobox-id)))
 582
 583        (defun stuff-user-point-comboboxes (&optional selectp)
 584          "Stuff user point attribute comboboxes with sensible values.
 585          If selectp it t, select the most frequently used one."
 586          (let* ((response
 587                  (chain *json-parser*
 588                         (read (@ *streetmap*
 589                                  user-point-choice-response response-text))))
 590                 (attributes
 591                  (chain response attributes (map (lambda (x)
 592                                                    (@ x attribute)))))
 593                 (descriptions
 594                  (chain response descriptions (map (lambda (x)
 595                                                      (@ x description)))))
 596                 (best-used-attribute -1)
 597                 (best-used-description -1))
 598            (when selectp
 599              (loop
 600                 with maximum = 0
 601                 for i across (@ response descriptions)
 602                 for k from 0
 603                 do (when (< maximum (@ i count))
 604                      (setf maximum (@ i count))
 605                      (setf best-used-description k)))
 606              (loop
 607                 with maximum = 0
 608                 for i across (@ response attributes)
 609                 for k from 0
 610                 do (when (< maximum (@ i count))
 611                      (setf maximum (@ i count))
 612                      (setf best-used-attribute k))))
 613            (stuff-combobox
 614             "point-attribute" attributes best-used-attribute)
 615            (stuff-combobox
 616             "point-description" descriptions best-used-description)))
 617
 618        (defun request-user-point-choice (&optional selectp)
 619          "Stuff user point attribute comboboxes with sensible values.
 620          If selectp it t, select the most frequently used one."
 621          (setf (@ *streetmap* user-point-choice-response)
 622                (chain
 623                 *open-layers
 624                 *Request
 625                 (*POST*
 626                  (create :url "/phoros/lib/user-point-attributes.json"
 627                          :data nil
 628                          :headers (create "Content-type" "text/plain")
 629                          :success (lambda ()
 630                                     (stuff-user-point-comboboxes selectp)))))))
 631
 632        (defun request-photos-after-click (event)
 633          "Handle the response to a click into *streetmap*; fetch photo
 634          data.  Set or update streetmap cursor."
 635          (request-photos (chain *streetmap*
 636                                 (get-lon-lat-from-pixel (@ event xy)))))
 637
 638        (defun request-photos (lonlat)
 639          "Fetch photo data for a point near lonlat.  Set or update
 640          streetmap cursor."
 641          (setf (@ *streetmap* clicked-lonlat) lonlat)
 642          (if (checkbox-status-with-id "walk-p")
 643              (request-aux-data-linestring-for-point
 644               (@ *streetmap* clicked-lonlat))
 645              (request-photos-for-point (@ *streetmap* clicked-lonlat))))
 646
 647        (defun request-aux-data-linestring-for-point (lonlat-spherical-mercator)
 648          "Fetch a linestring along auxiyliary points near
 649          lonlat-spherical-mercator."
 650          (let ((lonlat-geographic
 651                 (chain lonlat-spherical-mercator
 652                        (clone)
 653                        (transform +spherical-mercator+ +geographic+))))
 654            (request-aux-data-linestring (@ lonlat-geographic lon)
 655                                         (@ lonlat-geographic lat)
 656                                         (* *linestring-step-ratio*
 657                                            (step-size-degrees))
 658                                         (step-size-degrees))))
 659
 660        (defun request-photos-for-point (lonlat-spherical-mercator)
 661          "Fetch photo data near lonlat-spherical-mercator; set or
 662          update streetmap cursor."
 663          (disable-element-with-id "finish-point-button")
 664          (disable-element-with-id "remove-work-layers-button")
 665          (remove-any-layers "Estimated Position")
 666          (disable-streetmap-nearest-aux-points-layer)
 667          (reset-controls)
 668          (let* ((lonlat-geographic
 669                  (chain lonlat-spherical-mercator
 670                         (clone)
 671                         (transform +spherical-mercator+ +geographic+)))
 672                 (content
 673                  (chain *json-parser*
 674                         (write
 675                          (create :longitude (@ lonlat-geographic lon)
 676                                  :latitude (@ lonlat-geographic lat)
 677                                  :zoom (chain *streetmap* (get-zoom))
 678                                  :count (lisp *number-of-images*))))))
 679            (chain *streetmap*
 680                   cursor-layer
 681                   (remove-all-features))
 682            (chain *streetmap*
 683                   cursor-layer
 684                   (add-features
 685                    (new (chain *open-layers
 686                                *feature
 687                                (*vector
 688                                 (new (chain
 689                                       *open-layers
 690                                       *geometry
 691                                       (*point (@ lonlat-spherical-mercator
 692                                                  lon)
 693                                               (@ lonlat-spherical-mercator
 694                                                  lat)))))))))
 695            (chain *streetmap*
 696                   overview-cursor-layer
 697                   (remove-all-features))
 698            (chain *streetmap*
 699                   overview-cursor-layer
 700                   (add-features
 701                    (new (chain *open-layers
 702                                *feature
 703                                (*vector
 704                                 (new (chain
 705                                       *open-layers
 706                                       *geometry
 707                                       (*point (@ lonlat-spherical-mercator
 708                                                  lon)
 709                                               (@ lonlat-spherical-mercator
 710                                                  lat)))))))))
 711            (setf (@ *streetmap* photo-request-response)
 712                  (chain
 713                   *open-layers
 714                   *Request
 715                   (*POST*
 716                    (create
 717                     :url "/phoros/lib/local-data"
 718                     :data content
 719                     :headers (create "Content-type" "text/plain"
 720                                      "Content-length" (@ content length))
 721                     :success present-photos))))))
 722
 723        (defun draw-epipolar-line ()
 724          "Draw an epipolar line from response triggered by clicking
 725          into a (first) photo."
 726          (enable-element-with-id "remove-work-layers-button")
 727          (let* ((epipolar-line
 728                  (chain *json-parser*
 729                         (read
 730                          (@ this epipolar-request-response response-text))))
 731                 (points
 732                  (chain epipolar-line
 733                         (map (lambda (x)
 734                                (new (chain *open-layers
 735                                            *geometry
 736                                            (*point
 737                                             (@ x :m) (@ x :n))))))))
 738                 (feature
 739                  (new (chain *open-layers
 740                              *feature
 741                              (*vector
 742                               (new (chain
 743                                     *open-layers
 744                                     *geometry
 745                                     (*line-string points))))))))
 746            (setf (@ feature render-intent) "temporary")
 747            (chain this epipolar-layer
 748                   (add-features feature))))
 749        ;; either *line-string or *multi-point are usable
 750
 751        (defun request-nearest-aux-points (global-position count)
 752          "Draw into streetmap the count nearest points of auxiliary
 753          data."
 754          (let ((global-position-etc global-position)
 755                content)
 756            (setf (@ global-position-etc count) count)
 757            (setf content (chain *json-parser*
 758                                 (write global-position-etc)))
 759            (setf (@ *streetmap* aux-local-data-request-response)
 760                  (chain *open-layers
 761                         *Request
 762                         (*POST*
 763                          (create :url "/phoros/lib/aux-local-data"
 764                                  :data content
 765                                  :headers (create "Content-type" "text/plain"
 766                                                   "Content-length"
 767                                                   (@ content length))
 768                                  :success draw-nearest-aux-points))))))
 769
 770        (defun request-aux-data-linestring (longitude latitude radius step-size)
 771          "Draw into streetmap a piece of linestring threaded along the
 772          nearest points of auxiliary data inside radius."
 773          (let* ((payload (create longitude longitude
 774                                  latitude latitude
 775                                  radius radius
 776                                  step-size step-size
 777                                  azimuth (@ *streetmap*
 778                                             linestring-central-azimuth)))
 779                 (content (chain *json-parser* (write payload))))
 780            (setf (@ *streetmap* aux-data-linestring-request-response)
 781                  (chain *open-layers
 782                         *Request
 783                         (*POST*
 784                          (create :url "/phoros/lib/aux-local-linestring.json"
 785                                  :data content
 786                                  :headers (create "Content-type" "text/plain"
 787                                                   "Content-length"
 788                                                   (@ content length))
 789                                  :success draw-aux-data-linestring))))))
 790
 791        (defun draw-estimated-positions ()
 792          "Draw into streetmap and into all images points at Estimated
 793          Position.  Estimated Position is the point returned so far
 794          from photogrammetric calculations that are triggered by
 795          clicking into another photo.  Also draw into streetmap the
 796          nearest auxiliary points to Estimated Position."
 797          (when (write-permission-p)
 798            (setf (chain document
 799                         (get-element-by-id "finish-point-button")
 800                         onclick)
 801                  finish-point)
 802            (enable-element-with-id "finish-point-button"))
 803          (let* ((estimated-positions-request-response
 804                  (chain *json-parser*
 805                         (read
 806                          (@ this
 807                             estimated-positions-request-response
 808                             response-text))))
 809                 (estimated-positions
 810                  (aref estimated-positions-request-response 1))
 811                 (estimated-position-style
 812                  (create stroke-color (chain *open-layers
 813                                              *feature
 814                                              *vector
 815                                              style "temporary" stroke-color)
 816                          point-radius 9
 817                          fill-opacity 0)))
 818            (setf *global-position*
 819                  (aref estimated-positions-request-response 0))
 820            (let ((feature
 821                   (new
 822                    (chain *open-layers
 823                           *feature
 824                           (*vector
 825                            (chain
 826                             (new (chain *open-layers
 827                                         *geometry
 828                                         (*point
 829                                          (@ *global-position* longitude)
 830                                          (@ *global-position* latitude))))
 831                             (transform +geographic+ +spherical-mercator+)))))))
 832              (setf (@ feature render-intent) "temporary")
 833              (setf (@ *streetmap* estimated-position-layer)
 834                    (new (chain *open-layers
 835                                *layer
 836                                (*vector
 837                                 "Estimated Position"
 838                                 (create display-in-layer-switcher nil)))))
 839              (setf (@ *streetmap* estimated-position-layer style)
 840                    estimated-position-style)
 841              (chain *streetmap* estimated-position-layer (add-features feature))
 842              (chain *streetmap*
 843                     (add-layer (@ *streetmap* estimated-position-layer))))
 844            (request-nearest-aux-points *global-position* 7)
 845            (loop
 846               for i in *images*
 847               for p in estimated-positions
 848               do
 849               (when p    ;otherwise a photogrammetry error has occured
 850                 (setf (@ i estimated-position-layer)
 851                       (new
 852                        (chain *open-layers
 853                               *layer
 854                               (*vector
 855                                "Estimated Position"
 856                                (create display-in-layer-switcher nil)))))
 857                 (setf (@ i estimated-position-lonlat)
 858                       (new (chain *open-layers (*lon-lat (@ p m)
 859                                                          (@ p n)))))
 860                 (setf (@ i estimated-position-layer style)
 861                       estimated-position-style)
 862                 (let* ((point
 863                         (new
 864                          (chain *open-layers *geometry (*point (@ p m)
 865                                                                (@ p n)))))
 866                        (feature
 867                         (new
 868                          (chain *open-layers *feature (*vector point)))))
 869                   (chain i map
 870                          (add-layer (@ i estimated-position-layer)))
 871                   (chain i estimated-position-layer
 872                          (add-features feature))))))
 873          (zoom-anything-to-point)
 874          (chain document
 875                 (get-element-by-id "finish-point-button")
 876                 (focus)))
 877
 878        (defun draw-nearest-aux-points ()
 879          "Draw a few auxiliary points into streetmap."
 880          (reveal-element-with-id "include-aux-data")
 881          (reveal-element-with-id "aux-point-distance")
 882          (let ((features
 883                 (chain *json-parser*
 884                        (read
 885                         (@ *streetmap*
 886                            aux-local-data-request-response
 887                            response-text))
 888                        features)))
 889            (disable-streetmap-nearest-aux-points-layer)
 890            (chain *streetmap* user-points-select-control (deactivate))
 891            (chain *streetmap* nearest-aux-points-select-control (activate))
 892            (chain *streetmap* nearest-aux-points-hover-control (activate))
 893            (setf (@ *aux-point-distance-select* options length)
 894                  0)
 895            (loop
 896               for i in features
 897               for n from 0 do
 898               (let* ((point
 899                       (chain
 900                        (new
 901                         (chain *open-layers
 902                                *geometry
 903                                (*point (@ i geometry coordinates 0)
 904                                        (@ i geometry coordinates 1))))
 905                        (transform +geographic+ +spherical-mercator+)))
 906                      (feature
 907                       (new
 908                        (chain *open-layers *feature (*vector point)))))
 909                 (setf (@ feature attributes)
 910                       (@ i properties))
 911                 (setf (@ feature fid) ;this is supposed to correspond to
 912                       n)       ; option of *aux-point-distance-select*
 913                 (chain *streetmap*
 914                        nearest-aux-points-layer
 915                        (add-features feature))
 916                 (setf aux-point-distance-item
 917                       (chain document (create-element "option")))
 918                 (setf (@ aux-point-distance-item text)
 919                       (+
 920                        "("
 921                        n ;let's hope add-features alway stores features in order of arrival
 922                        ") "
 923                        (chain *open-layers
 924                               *number
 925                               (format (@ i properties distance) 3 ""))))
 926                 (chain *aux-point-distance-select*
 927                        (add aux-point-distance-item null))))
 928            (chain *streetmap*
 929                   nearest-aux-points-select-control
 930                   (select
 931                    (chain
 932                     (elt (@ *streetmap* nearest-aux-points-layer features)
 933                          0))))
 934            (enable-element-with-id "aux-point-distance")))
 935
 936        (defun draw-aux-data-linestring ()
 937          "Draw a piece of linestring along a few auxiliary points into
 938          streetmap.  Pan streetmap accordingly."
 939          (let* ((data
 940                  (@ *streetmap*
 941                     aux-data-linestring-request-response
 942                     response-text))
 943                 (linestring-wkt
 944                  (chain *json-parser* (read data) linestring))
 945                 (current-point-wkt
 946                  (chain *json-parser* (read data) current-point))
 947                 (previous-point-wkt
 948                  (chain *json-parser* (read data) previous-point))
 949                 (next-point-wkt
 950                  (chain *json-parser* (read data) next-point))
 951                 (azimuth
 952                  (chain *json-parser* (read data) azimuth))
 953                 (linestring
 954                  (chain *wkt-parser* (read linestring-wkt)))
 955                 (current-point
 956                  (chain *wkt-parser* (read current-point-wkt)))
 957                 (previous-point
 958                  (chain *wkt-parser* (read previous-point-wkt)))
 959                 (next-point
 960                  (chain *wkt-parser* (read next-point-wkt)))
 961                 (current-point-lonlat
 962                  (new (chain *open-layers
 963                              (*lon-lat (@ current-point geometry x)
 964                                        (@ current-point geometry y))))))
 965            (chain *streetmap* (pan-to current-point-lonlat))
 966            (setf (@ *streetmap* linestring-central-azimuth) azimuth)
 967            (request-photos-for-point current-point-lonlat)
 968            (setf (@ *streetmap* step-back-point) previous-point)
 969            (setf (@ *streetmap* step-forward-point) next-point)
 970            (chain *streetmap* aux-data-linestring-layer (remove-all-features))
 971            (chain *streetmap*
 972                   aux-data-linestring-layer
 973                   (add-features linestring))))
 974
 975        (defun step (&optional back-p)
 976          "Enable walk-mode if necessary, and do a step along
 977          aux-data-linestring."
 978          (if (checkbox-status-with-id "walk-p")
 979              (let ((next-point-geometry
 980                     (if back-p
 981                         (progn
 982                           (if (< (- (@ *streetmap* linestring-central-azimuth) pi) 0)
 983                               (setf (@ *streetmap* linestring-central-azimuth)
 984                                     (+ (@ *streetmap* linestring-central-azimuth) pi))
 985                               (setf (@ *streetmap* linestring-central-azimuth)
 986                                     (- (@ *streetmap* linestring-central-azimuth) pi)))
 987                           (chain *streetmap*
 988                                  step-back-point
 989                                  (clone)
 990                                  geometry
 991                                  (transform +spherical-mercator+ +geographic+)))
 992                         (chain *streetmap*
 993                                step-forward-point
 994                                (clone)
 995                                geometry
 996                                (transform +spherical-mercator+ +geographic+)))))
 997                (request-aux-data-linestring (@ next-point-geometry x)
 998                                             (@ next-point-geometry y)
 999                                             (* *linestring-step-ratio*
1000                                                (step-size-degrees))
1001                                             (step-size-degrees)))
1002              (progn
1003                (setf (checkbox-status-with-id "walk-p") t) ;doesn't seem to trigger event
1004                (flip-walk-mode))))    ; so we have to do it explicitly
1005
1006        (defun step-size-degrees ()
1007          "Return inner-html of element step-size (metres) converted
1008          into map units (degrees).  You should be close to the
1009          equator."
1010          (/ (inner-html-with-id "step-size") 1855.325 60))
1011
1012        (defun decrease-step-size ()
1013          (when (> (inner-html-with-id "step-size") 0.5)
1014            (setf (inner-html-with-id "step-size")
1015                  (/ (inner-html-with-id "step-size") 2))))
1016
1017        (defun increase-step-size ()
1018          (when (< (inner-html-with-id "step-size") 100)
1019            (setf (inner-html-with-id "step-size")
1020                  (* (inner-html-with-id "step-size") 2))))
1021
1022        (defun user-point-style-map (label-property)
1023          "Create a style map where styles dispatch on feature property
1024          \"attribute\" and features are labelled after feature
1025          property label-property."
1026          (let* ((symbolizer-property "attribute")
1027                 (solitary-filter
1028                  (new (chain *open-layers
1029                              *filter
1030                              (*comparison (create type (chain *open-layers
1031                                                               *filter
1032                                                               *comparison
1033                                                               *like*)
1034                                                   property symbolizer-property
1035                                                   value "solitary")))))
1036                 (polyline-filter
1037                  (new (chain *open-layers
1038                              *filter
1039                              (*comparison (create type (chain *open-layers
1040                                                               *filter
1041                                                               *comparison
1042                                                               *like*)
1043                                                   property symbolizer-property
1044                                                   value "polyline")))))
1045                 (polygon-filter
1046                  (new (chain *open-layers
1047                              *filter
1048                              (*comparison (create type (chain *open-layers
1049                                                               *filter
1050                                                               *comparison
1051                                                               *like*)
1052                                                   property symbolizer-property
1053                                                   value "polygon")))))
1054                 (solitary-rule
1055                  (new (chain *open-layers
1056                              (*rule (create
1057                                      filter solitary-filter
1058                                      symbolizer (create
1059                                                  graphic-name "triangle"))))))
1060                 (polyline-rule
1061                  (new (chain *open-layers
1062                              (*rule (create
1063                                      filter polyline-filter
1064                                      symbolizer (create
1065                                                  graphic-name "square"
1066                                                  point-radius 4))))))
1067                 (polygon-rule
1068                  (new (chain *open-layers
1069                              (*rule (create
1070                                      filter polygon-filter
1071                                      symbolizer (create
1072                                                  graphic-name "star"))))))
1073                 (else-rule
1074                  (new (chain *open-layers
1075                              (*rule (create
1076                                      else-filter t
1077                                      symbolizer (create
1078                                                  graphic-name "x"))))))
1079                 (user-point-default-style
1080                  (new (chain
1081                        *open-layers
1082                        (*style (create stroke-color "OrangeRed"
1083                                        fill-color "OrangeRed"
1084                                        label-align "cb"
1085                                        label-y-offset 5
1086                                        font-color "OrangeRed"
1087                                        font-family "'andale mono', 'lucida console', monospace"
1088                                        stroke-opacity .5
1089                                        stroke-width 2
1090                                        point-radius 5
1091                                        fill-opacity 0)
1092                                (create rules (array solitary-rule
1093                                                     polyline-rule
1094                                                     polygon-rule
1095                                                     else-rule))))))
1096                 (user-point-select-style
1097                  (new (chain
1098                        *open-layers
1099                        (*style (create stroke-opacity 1
1100                                        label label-property)
1101                                (create rules (array solitary-rule
1102                                                     polyline-rule
1103                                                     polygon-rule
1104                                                     else-rule))))))
1105                 (user-point-temporary-style
1106                  (new (chain
1107                        *open-layers
1108                        (*style (create fill-opacity .5)
1109                                (create rules (array solitary-rule
1110                                                     polyline-rule
1111                                                     polygon-rule
1112                                                     else-rule)))))))
1113            (new (chain *open-layers
1114                        (*style-map
1115                         (create "default" user-point-default-style
1116                                 "temporary" user-point-temporary-style
1117                                 "select" user-point-select-style))))))
1118
1119        (defun draw-user-points ()
1120          "Draw currently selected user points into all images."
1121          (let* ((user-point-positions-response
1122                  (chain *json-parser*
1123                         (read
1124                          (@ *user-point-in-images-response* response-text))))
1125                 (user-point-collections
1126                  (chain user-point-positions-response image-points))
1127                 (user-point-count
1128                  (chain user-point-positions-response user-point-count))
1129                 (label
1130                  (when (> user-point-count 1) "${numericDescription}")))
1131            (loop
1132               for i in *images*
1133               for user-point-collection in user-point-collections
1134               do
1135               (when i    ;otherwise a photogrammetry error has occured
1136                 (let ((features
1137                        (loop
1138                           for raw-feature in
1139                           (@ user-point-collection features)
1140                           collect
1141                           (let* ((x
1142                                   (@ raw-feature geometry coordinates 0))
1143                                  (y
1144                                   (@ raw-feature geometry coordinates 1))
1145                                  (point
1146                                   (new (chain *open-layers
1147                                               *geometry
1148                                               (*point x y))))
1149                                  (fid
1150                                   (@ raw-feature id))
1151                                  (attributes
1152                                   (@ raw-feature properties))
1153                                  (feature
1154                                   (new (chain *open-layers
1155                                               *feature
1156                                               (*vector point attributes)))))
1157                             (setf (@ feature fid) fid)
1158                             (setf (@ feature render-intent) "select")
1159                             feature))))
1160                   (setf
1161                    (@ i user-point-layer)
1162                    (new (chain *open-layers
1163                                *layer
1164                                (*vector
1165                                 "User Point"
1166                                 (create display-in-layer-switcher nil
1167                                         style-map (user-point-style-map
1168                                                    label))))))
1169                   (chain i map (add-layer (@ i user-point-layer)))
1170                   (chain i user-point-layer (add-features features)))))))
1171
1172        (defun finish-point ()
1173          "Send current *global-position* as a user point to the database."
1174          (let ((global-position-etc *global-position*))
1175            (setf (@ global-position-etc attribute)
1176                  (value-with-id "point-attribute-input"))
1177            (setf (@ global-position-etc description)
1178                  (value-with-id "point-description-input"))
1179            (setf (@ global-position-etc numeric-description)
1180                  (value-with-id "point-numeric-description"))
1181            (when (checkbox-status-with-id "include-aux-data-p")
1182              (setf (@ global-position-etc aux-numeric)
1183                    (@ *current-nearest-aux-point*
1184                       attributes
1185                       aux-numeric))
1186              (setf (@ global-position-etc aux-text)
1187                    (@ *current-nearest-aux-point*
1188                       attributes
1189                       aux-text)))
1190            (let ((content
1191                   (chain *json-parser*
1192                          (write global-position-etc))))
1193              (chain
1194               *open-layers
1195               *Request
1196               (*POST*
1197                (create :url "/phoros/lib/store-point"
1198                        :data content
1199                        :headers (create "Content-type" "text/plain"
1200                                         "Content-length" (@ content length))
1201                        :success (lambda ()
1202                                   (refresh-layer
1203                                    (@ *streetmap* user-point-layer))
1204                                   (reset-layers-and-controls)
1205                                   (request-user-point-choice))))))))
1206
1207        (defun increment-numeric-text (text)
1208          "Increment text if it looks like a number, and return it."
1209          (let* ((parts (chain (regex "(\\D*)(\\d*)(.*)") (exec text)))
1210                 (old-number (elt parts 2))
1211                 (new-number (1+ (parse-int old-number 10)))))
1212          (if (is-finite new-number)
1213              (+ (elt parts 1) new-number (elt parts 3))
1214              text))
1215
1216        (defun update-point ()
1217          "Send changes to currently selected user point to database."
1218          (let* ((point-data
1219                  (create user-point-id (@ *current-user-point* fid)
1220                          attribute
1221                          (value-with-id "point-attribute-input")
1222                          description
1223                          (value-with-id "point-description-input")
1224                          numeric-description
1225                          (value-with-id "point-numeric-description")))
1226                 (content
1227                  (chain *json-parser*
1228                         (write point-data))))
1229            (chain *open-layers
1230                   *Request
1231                   (*POST*
1232                    (create :url "/phoros/lib/update-point"
1233                            :data content
1234                            :headers (create "Content-type" "text/plain"
1235                                             "Content-length" (@ content
1236                                                                 length))
1237                            :success (lambda ()
1238                                       (refresh-layer
1239                                        (@ *streetmap* user-point-layer))
1240                                       (reset-layers-and-controls)
1241                                       (request-user-point-choice)))))))
1242
1243        (defun delete-point ()
1244          "Purge currently selected user point from database."
1245          (let ((user-point-id (@ *current-user-point* fid)))
1246            (setf content
1247                  (chain *json-parser*
1248                         (write user-point-id)))
1249            (chain *open-layers
1250                   *Request
1251                   (*POST*
1252                    (create :url "/phoros/lib/delete-point"
1253                            :data content
1254                            :headers (create "Content-type" "text/plain"
1255                                             "Content-length" (@ content
1256                                                                 length))
1257                            :success (lambda ()
1258                                       (refresh-layer
1259                                        (@ *streetmap* user-point-layer))
1260                                       (reset-layers-and-controls)
1261                                       (request-user-point-choice true)))))))
1262
1263        (defun draw-active-point ()
1264          "Draw an Active Point, i.e. a point used in subsequent
1265          photogrammetric calculations."
1266          (chain this
1267                 active-point-layer
1268                 (add-features
1269                  (new (chain *open-layers
1270                              *feature
1271                              (*vector
1272                               (new (chain *open-layers
1273                                           *geometry
1274                                           (*point
1275                                            (@ this photo-parameters m)
1276                                            (@ this photo-parameters n))))))))))
1277
1278        (defun image-click-action (clicked-image)
1279          (lambda (event)
1280            "Do appropriate things when an image is clicked into."
1281            (let* ((lonlat
1282                    (chain clicked-image map (get-lon-lat-from-view-port-px
1283                                              (@ event xy))))
1284                   (photo-parameters
1285                    (@ clicked-image photo-parameters))
1286                   pristine-image-p content request)
1287              (when (and (@ photo-parameters usable)
1288                         (chain clicked-image (photop)))
1289                (setf (@ photo-parameters m) (@ lonlat lon)
1290                      (@ photo-parameters n) (@ lonlat lat))
1291                (remove-layer (@ clicked-image map) "Active Point")
1292                (remove-any-layers "Epipolar Line")
1293                (setf *pristine-images-p* (not (some-active-point-p)))
1294                (setf (@ clicked-image active-point-layer)
1295                      (new (chain *open-layers
1296                                  *layer
1297                                  (*vector "Active Point"
1298                                           (create display-in-layer-switcher
1299                                                   nil)))))
1300                (chain clicked-image
1301                       map
1302                       (add-layer (@ clicked-image active-point-layer)))
1303                (chain clicked-image (draw-active-point))
1304                (if
1305                 *pristine-images-p*
1306                 (progn
1307                   (chain *streetmap* user-points-select-control (unselect-all))
1308                   (reset-controls)
1309                   (setf (value-with-id "point-numeric-description")
1310                         (increment-numeric-text
1311                          (value-with-id "point-numeric-description")))
1312                   (remove-any-layers "User Point") ;from images
1313                   (loop
1314                      for i across *images* do
1315                      (when (and (not (equal i clicked-image))
1316                                 (chain i (photop)))
1317                        (setf
1318                         (@ i epipolar-layer)
1319                         (new (chain *open-layers
1320                                     *layer
1321                                     (*vector "Epipolar Line"
1322                                              (create
1323                                               display-in-layer-switcher nil))))
1324                         content (chain *json-parser*
1325                                        (write
1326                                         (append (array photo-parameters)
1327                                                 (@ i photo-parameters))))
1328                         (@ i epipolar-request-response)
1329                         (chain *open-layers
1330                                *Request
1331                                (*POST*
1332                                 (create :url "/phoros/lib/epipolar-line"
1333                                         :data content
1334                                         :headers (create
1335                                                   "Content-type" "text/plain"
1336                                                   "Content-length"
1337                                                   (@ content length))
1338                                         :success (@ i draw-epipolar-line)
1339                                         :scope i))))
1340                        (chain i
1341                               map
1342                               (add-layer (@ i epipolar-layer))))))
1343                 (progn
1344                   (remove-any-layers "Epipolar Line")
1345                   (remove-any-layers "Estimated Position")
1346                   (let* ((active-pointed-photo-parameters
1347                           (loop
1348                              for i across *images*
1349                              when (has-layer-p (@ i map) "Active Point")
1350                              collect (@ i photo-parameters)))
1351                          (content
1352                           (chain *json-parser*
1353                                  (write
1354                                   (list active-pointed-photo-parameters
1355                                         (chain *images*
1356                                                (map
1357                                                 #'(lambda (x)
1358                                                     (@ x
1359                                                        photo-parameters)))))))))
1360                     (setf (@ clicked-image estimated-positions-request-response)
1361                           (chain *open-layers
1362                                  *Request
1363                                  (*POST*
1364                                   (create :url "/phoros/lib/estimated-positions"
1365                                           :data content
1366                                           :headers (create
1367                                                     "Content-type" "text/plain"
1368                                                     "Content-length"
1369                                                     (@ content length))
1370                                           :success (@ clicked-image
1371                                                       draw-estimated-positions)
1372                                           :scope clicked-image)))))))))))
1373
1374        (defun iso-time-string (lisp-time)
1375          "Return Lisp universal time formatted as ISO time string"
1376          (let* ((unix-time (- lisp-time +unix-epoch+))
1377                 (js-date (new (*date (* 1000 unix-time)))))
1378            (chain *open-layers *date (to-i-s-o-string js-date))))
1379
1380        (defun delete-photo ()
1381          "Delete this object's photo."
1382          (loop
1383             repeat (chain this map (get-num-layers))
1384             do (chain this map layers 0 (destroy)))
1385          (hide-element-with-id (@ this usable-id))
1386          (setf (@ this trigger-time-div inner-h-t-m-l) nil))
1387
1388        (defun photop ()
1389          "Check if this object contains a photo."
1390          (@ this trigger-time-div inner-h-t-m-l))
1391
1392        (defun show-photo ()
1393          "Show the photo described in this object's photo-parameters."
1394          (let ((image-div-width
1395                 (parse-int (chain (get-computed-style (@ this map div) nil)
1396                                   width)))
1397                (image-div-height
1398                 (parse-int (chain (get-computed-style (@ this map div) nil)
1399                                   height)))
1400                (image-width
1401                 (@ this photo-parameters sensor-width-pix))
1402                (image-height
1403                 (@ this photo-parameters sensor-height-pix)))
1404            (chain
1405             this
1406             map
1407             (add-layer
1408              (new (chain
1409                    *open-layers
1410                    *layer
1411                    (*image
1412                     "Photo"
1413                     (photo-path (@ this photo-parameters))
1414                     (new (chain *open-layers
1415                                 (*bounds
1416                                  -.5 -.5
1417                                  (+ image-width .5) (+ image-height .5))))
1418                     (new (chain *open-layers
1419                                 (*size image-div-width
1420                                        image-div-height)))
1421                     (create
1422                      max-resolution (chain
1423                                      *math
1424                                      (max
1425                                       (/ image-width image-div-width)
1426                                       (/ image-height image-div-height)))))))))
1427            (chain this map (zoom-to-max-extent))
1428            (if (@ this photo-parameters usable)
1429                (hide-element-with-id (@ this usable-id))
1430                (reveal-element-with-id (@ this usable-id)))
1431            (setf (@ this trigger-time-div inner-h-t-m-l)
1432                  (iso-time-string (@ this photo-parameters trigger-time)))))
1433
1434        (defun zoom-images-to-max-extent ()
1435          "Zoom out all images."
1436          (loop for i across *images* do (chain i map (zoom-to-max-extent))))
1437
1438        (defun zoom-anything-to-point ()
1439          "For streetmap and for images that have an Active Point or an
1440          Estimated Position, zoom in and recenter."
1441          (when (checkbox-status-with-id "zoom-to-point-p")
1442            (let ((point-lonlat
1443                   (new (chain *open-layers
1444                               (*lon-lat (@ *global-position* longitude)
1445                                         (@ *global-position* latitude))
1446                               (transform +geographic+ +spherical-mercator+)))))
1447              (when point-lonlat
1448                (chain *streetmap*
1449                       (set-center point-lonlat 18 nil t))))
1450            (loop for i across *images* do
1451                 (let ((point-lonlat
1452                        (cond
1453                          ((has-layer-p (@ i map) "Active Point")
1454                           (new (chain *open-layers (*lon-lat
1455                                                     (@ i photo-parameters m)
1456                                                     (@ i photo-parameters n)))))
1457                          ((has-layer-p (@ i map) "Estimated Position")
1458                           (@ i estimated-position-lonlat))
1459                          (t false))))
1460                   (when point-lonlat
1461                     (chain i map (set-center point-lonlat 4 nil t)))))))
1462
1463        (defun initialize-image (image-index)
1464          "Create an image usable for displaying photos at position
1465          image-index in array *images*."
1466          (setf (aref *images* image-index) (new *image))
1467          (setf (@ (aref *images* image-index) usable-id)
1468                (+ "image-" image-index "-usable"))
1469          (hide-element-with-id (+ "image-" image-index "-usable"))
1470          (setf (@ (aref *images* image-index) trigger-time-div)
1471                (chain
1472                 document
1473                 (get-element-by-id (+ "image-" image-index "-trigger-time"))))
1474          (setf (@ (aref *images* image-index) image-click-action)
1475                (image-click-action (aref *images* image-index)))
1476          (setf (@ (aref *images* image-index) click)
1477                (new (*click-control*
1478                      (create :trigger (@ (aref *images* image-index)
1479                                          image-click-action)))))
1480          (chain (aref *images* image-index)
1481                 map
1482                 (add-control
1483                  (@ (aref *images* image-index) click)))
1484          (chain (aref *images* image-index) click (activate))
1485          ;;(chain (aref *images* image-index)
1486          ;;       map
1487          ;;       (add-control
1488          ;;        (new (chain *open-layers
1489          ;;                    *control
1490          ;;                    (*mouse-position
1491          ;;                     (create
1492          ;;                      div (chain
1493          ;;                           document
1494          ;;                           (get-element-by-id
1495          ;;                            (+ "image-" image-index "-zoom")))))))))
1496          (chain (aref *images* image-index)
1497                 map
1498                 (add-control
1499                  (new (chain *open-layers
1500                              *control
1501                              (*layer-switcher
1502                               (create
1503                                div (chain
1504                                     document
1505                                     (get-element-by-id
1506                                      (+ "image-" image-index "-layer-switcher")))
1507                                rounded-corner nil))))))
1508          (let ((pan-west-control
1509                 (new (chain *open-layers *control (*pan "West"))))
1510                (pan-north-control
1511                 (new (chain *open-layers *control (*pan "North"))))
1512                (pan-south-control
1513                 (new (chain *open-layers *control (*pan "South"))))
1514                (pan-east-control
1515                 (new (chain *open-layers *control (*pan "East"))))
1516                (zoom-in-control
1517                 (new (chain *open-layers *control (*zoom-in))))
1518                (zoom-out-control
1519                 (new (chain *open-layers *control (*zoom-out))))
1520                (zoom-to-max-extent-control
1521                 (new (chain *open-layers *control (*zoom-to-max-extent))))
1522                (pan-zoom-panel
1523                 (new (chain *open-layers
1524                             *control
1525                             (*panel
1526                              (create div
1527                                      (chain
1528                                       document
1529                                       (get-element-by-id
1530                                        (+ "image-" image-index "-zoom")))))))))
1531            (chain (aref *images* image-index)
1532                   map
1533                   (add-control pan-zoom-panel))
1534            (chain pan-zoom-panel
1535                   (add-controls (array pan-west-control
1536                                        pan-north-control
1537                                        pan-south-control
1538                                        pan-east-control
1539                                        zoom-in-control
1540                                        zoom-out-control
1541                                        zoom-to-max-extent-control))))
1542          (chain (aref *images* image-index)
1543                 map
1544                 (render (chain document
1545                                (get-element-by-id
1546                                 (+ "image-" image-index))))))
1547
1548        (defun user-point-selected (event)
1549          "Things to do once a user point is selected."
1550          (remove-any-layers "Active Point")
1551          (remove-any-layers "Epipolar Line")
1552          (remove-any-layers "Estimated Position")
1553          (unselect-combobox-selection "point-attribute")
1554          (unselect-combobox-selection "point-description")
1555          (user-point-selection-changed))
1556
1557        (defun user-point-unselected (event)
1558          "Things to do once a user point is unselected."
1559          (reset-controls)
1560          (user-point-selection-changed))
1561
1562        (defun user-point-selection-changed ()
1563          "Things to do once a user point is selected or unselected."
1564          (hide-aux-data-choice)
1565          (setf *current-user-point*
1566                (@ *streetmap* user-point-layer selected-features 0))
1567          (let ((selected-features-count
1568                 (@ *streetmap* user-point-layer selected-features length)))
1569            (setf (@ *streetmap* user-point-layer style-map)
1570                  (user-point-style-map
1571                   (when (> selected-features-count 1)
1572                     "${numericDescription}")))
1573            (cond
1574              ((> selected-features-count 1)
1575               (hide-element-with-id "real-phoros-controls")
1576               (reveal-element-with-id "multiple-points-phoros-controls"))
1577              ((= selected-features-count 1)
1578               (setf (value-with-id "point-attribute-input")
1579                     (@ *current-user-point* attributes attribute))
1580               (setf (value-with-id "point-description-input")
1581                     (@ *current-user-point* attributes description))
1582               (setf (value-with-id "point-numeric-description")
1583                     (@ *current-user-point* attributes numeric-description))
1584               (setf (inner-html-with-id "point-creation-date")
1585                     (@ *current-user-point* attributes creation-date))
1586               (setf (inner-html-with-id "aux-numeric-list")
1587                     (html-ordered-list
1588                      (@ *current-user-point* attributes aux-numeric)))
1589               (setf (inner-html-with-id "aux-text-list")
1590                     (html-ordered-list
1591                      (@ *current-user-point* attributes aux-text)))
1592               (if (write-permission-p
1593                    (@ *current-user-point* attributes user-name))
1594                   (progn
1595                     (setf (chain document
1596                                  (get-element-by-id "finish-point-button")
1597                                  onclick)
1598                           update-point)
1599                     (enable-element-with-id "finish-point-button")
1600                     (enable-element-with-id "delete-point-button")
1601                     (setf (inner-html-with-id "h2-controls") "Edit Point"))
1602                   (progn
1603                     (disable-element-with-id "finish-point-button")
1604                     (disable-element-with-id "delete-point-button")
1605                     (setf (inner-html-with-id "h2-controls") "View Point")))
1606               (setf (inner-html-with-id "creator")
1607                     (+ "(by "
1608                        (@ *current-user-point* attributes user-name)
1609                        ")")))
1610              (t
1611               (hide-element-with-id "multiple-points-phoros-controls")
1612               (reveal-element-with-id "real-phoros-controls"))))
1613          (chain *streetmap* user-point-layer (redraw))
1614          (remove-any-layers "User Point") ;from images
1615          (setf content
1616                (chain *json-parser*
1617                       (write
1618                        (array (chain *streetmap*
1619                                      user-point-layer
1620                                      selected-features
1621                                      (map (lambda (x) (@ x fid))))
1622                               (loop
1623                                  for i across *images*
1624                                  collect (@ i photo-parameters))))))
1625          (setf *user-point-in-images-response*
1626                (chain *open-layers
1627                       *Request
1628                       (*POST*
1629                        (create :url "/phoros/lib/user-point-positions"
1630                                :data content
1631                                :headers (create "Content-type" "text/plain"
1632                                                 "Content-length" (@ content
1633                                                                     length))
1634                                :success draw-user-points)))))
1635
1636        (defun aux-point-distance-selected ()
1637          "Things to do on change of aux-point-distance select element."
1638          (chain *streetmap*
1639                 nearest-aux-points-select-control
1640                 (unselect-all))
1641          (chain *streetmap*
1642                 nearest-aux-points-select-control
1643                 (select
1644                  (chain
1645                   (elt (@ *streetmap* nearest-aux-points-layer features)
1646                        (@ *aux-point-distance-select*
1647                           options
1648                           selected-index))))))
1649
1650        (defun enable-aux-point-selection ()
1651          "Check checkbox include-aux-data-p and act accordingly."
1652          (setf (checkbox-status-with-id "include-aux-data-p") t)
1653          (flip-aux-data-inclusion))
1654
1655        (defun flip-walk-mode ()
1656          "Query status of checkbox walk-p and induce first walking
1657          step if it's just been turned on.  Otherwise delete our
1658          walking path."
1659          (if (checkbox-status-with-id "walk-p")
1660              (request-aux-data-linestring-for-point (@ *streetmap*
1661                                                        clicked-lonlat))
1662              (chain *streetmap*
1663                     aux-data-linestring-layer
1664                     (remove-all-features))))
1665
1666        (defun flip-aux-data-inclusion ()
1667          "Query status of checkbox include-aux-data-p and act
1668          accordingly."
1669          (if (checkbox-status-with-id "include-aux-data-p")
1670              (chain *streetmap*
1671                     nearest-aux-points-layer
1672                     (set-visibility t))
1673              (chain *streetmap*
1674                     nearest-aux-points-layer
1675                     (set-visibility nil))))
1676
1677        (defun html-ordered-list (aux-data)
1678          "Return a html-formatted list from aux-data."
1679          (if aux-data
1680              (who-ps-html
1681               (:ol :class "aux-data-list"
1682                    (chain aux-data
1683                           (reduce (lambda (x y)
1684                                     (+ x (who-ps-html (:li y))))
1685                                   ""))))
1686              ""))
1687
1688        (defun nearest-aux-point-selected (event)
1689          "Things to do once a nearest auxiliary point is selected in
1690          streetmap."
1691          (setf *current-nearest-aux-point* (@ event feature))
1692          (let ((aux-numeric
1693                 (@ event feature attributes aux-numeric))
1694                (aux-text
1695                 (@ event feature attributes aux-text))
1696                (distance
1697                 (@ event feature attributes distance)))
1698            (setf (@ *aux-point-distance-select* options selected-index)
1699                  (@ event feature fid))
1700            (setf (inner-html-with-id "aux-numeric-list")
1701                  (html-ordered-list aux-numeric))
1702            (setf (inner-html-with-id "aux-text-list")
1703                  (html-ordered-list aux-text))))
1704
1705        (defun bye ()
1706          "Store user's current map extent and log out."
1707          (let* ((bbox (chain *streetmap*
1708                              (get-extent)
1709                              (transform +spherical-mercator+ +geographic+)
1710                              (to-b-b-o-x)))
1711                 (href (+ "/phoros/lib/logout?bbox=" bbox)))
1712            (when (@ *streetmap* cursor-layer features length)
1713              (let* ((lonlat-geographic (chain *streetmap*
1714                                               cursor-layer
1715                                               features
1716                                               0
1717                                               geometry
1718                                               (clone)
1719                                               (transform +spherical-mercator+
1720                                                          +geographic+))))
1721                (setf href (+ href
1722                              "&longitude=" (@ lonlat-geographic x)
1723                              "&latitude=" (@ lonlat-geographic y)))))
1724            (setf (@ location href) href)))
1725
1726        (defun init ()
1727          "Prepare user's playground."
1728          (unless +presentation-project-bbox-text+
1729            (setf (inner-html-with-id "presentation-project-emptiness")
1730                  "(no data)"))
1731          (setf *streetmap*
1732                (new (chain
1733                      *open-layers
1734                      (*map "streetmap"
1735                            (create projection +geographic+
1736                                    display-projection +geographic+
1737                                    controls (array (new (chain *open-layers
1738                                                                *control
1739                                                                (*navigation)))
1740                                                    (new (chain *open-layers
1741                                                                *control
1742                                                                (*attribution)))))))))
1743          (unless +aux-data-p+
1744            (disable-element-with-id "walk-p")
1745            (hide-element-with-id "decrease-step-size")
1746            (hide-element-with-id "step-size")
1747            (hide-element-with-id "increase-step-size")
1748            (hide-element-with-id "step-button"))
1749          (when (write-permission-p)
1750            (enable-element-with-id "point-attribute-input")
1751            (enable-element-with-id "point-attribute-select")
1752            (enable-element-with-id "point-description-input")
1753            (enable-element-with-id "point-description-select")
1754            (enable-element-with-id "point-numeric-description")
1755            (request-user-point-choice true))
1756          (setf (inner-html-with-id "h2-controls") "Create Point")
1757          (hide-element-with-id "multiple-points-phoros-controls")
1758          (setf *point-attributes-select*
1759                (chain document (get-element-by-id "point-attribute-select")))
1760          (setf *aux-point-distance-select*
1761                (chain document (get-element-by-id "aux-point-distance")))
1762          (hide-aux-data-choice)
1763          (let ((cursor-layer-style
1764                 (create
1765                  graphic-width 14
1766                  external-graphic "/phoros/lib/public_html/phoros-cursor.png")))
1767            (setf (@ *streetmap* cursor-layer)
1768                  (new (chain
1769                        *open-layers *layer
1770                        (*vector
1771                         "you"
1772                         (create
1773                          style cursor-layer-style)))))
1774            (setf (@ *streetmap* overview-cursor-layer)
1775                  (new (chain
1776                        *open-layers *layer
1777                        (*vector
1778                         "you"
1779                         (create
1780                          style cursor-layer-style))))))
1781          (let ((survey-layer-style
1782                 (create stroke-color (chain *open-layers *feature *vector
1783                                             style "default" stroke-color)
1784                         stroke-width 1
1785                         point-radius 2
1786                         fill-opacity 0
1787                         graphic-name "circle")))
1788            (setf (@ *streetmap* survey-layer)
1789                  (new (chain
1790                        *open-layers *layer
1791                        (*vector
1792                         "survey"
1793                         (create
1794                          strategies (array (new (*bbox-strategy*)))
1795                          protocol
1796                          (new (*http-protocol*
1797                                (create :url "/phoros/lib/points.json")))
1798                          style survey-layer-style))))))
1799          (setf (@ *streetmap* user-point-layer)
1800                (new (chain
1801                      *open-layers *layer
1802                      (*vector
1803                       "user points"
1804                       (create
1805                        strategies (array (new *bbox-strategy*))
1806                        protocol
1807                        (new (*http-protocol*
1808                              (create :url "/phoros/lib/user-points.json")))
1809                        style-map (user-point-style-map nil))))))
1810          (setf (@ *streetmap* user-points-hover-control)
1811                (new (chain *open-layers
1812                            *control
1813                            (*select-feature (@ *streetmap* user-point-layer)
1814                                             (create render-intent "temporary"
1815                                                     hover t
1816                                                     highlight-only t)))))
1817          (setf (@ *streetmap* user-points-select-control)
1818                (new (chain *open-layers
1819                            *control
1820                            (*select-feature (@ *streetmap* user-point-layer)
1821                                             (create toggle t
1822                                                     multiple t)))))
1823          (let ((aux-layer-style
1824                 (create stroke-color "grey"
1825                         stroke-width 1
1826                         point-radius 2
1827                         fill-opacity 0
1828                         graphic-name "circle")))
1829            (setf (@ *streetmap* aux-point-layer)
1830                  (new (chain
1831                        *open-layers *layer
1832                        (*vector
1833                         "auxiliary data"
1834                         (create
1835                          strategies (array (new (*bbox-strategy*)))
1836                          protocol
1837                          (new (*http-protocol*
1838                                (create :url "/phoros/lib/aux-points.json")))
1839                          style aux-layer-style
1840                          visibility nil))))))
1841          (let ((nearest-aux-point-layer-style-map
1842                 (new (chain *open-layers
1843                             (*style-map
1844                              (create "default"
1845                                      (create stroke-color "grey"
1846                                              stroke-width 1
1847                                              point-radius 5
1848                                              fill-opacity 0
1849                                              graphic-name "circle")
1850                                      "select"
1851                                      (create stroke-color "black"
1852                                              stroke-width 1
1853                                              point-radius 5
1854                                              fill-opacity 0
1855                                              graphic-name "circle")
1856                                      "temporary"
1857                                      (create stroke-color "grey"
1858                                              stroke-width 1
1859                                              point-radius 5
1860                                              fill-color "grey"
1861                                              fill-opacity 1
1862                                              graphic-name "circle")))))))
1863            (setf (@ *streetmap* nearest-aux-points-layer)
1864                  (new (chain *open-layers
1865                              *layer
1866                              (*vector
1867                               "Nearest Aux Points"
1868                               (create
1869                                display-in-layer-switcher nil
1870                                style-map nearest-aux-point-layer-style-map
1871                                visibility t))))))
1872          (setf (@ *streetmap* nearest-aux-points-hover-control)
1873                (new (chain *open-layers
1874                            *control
1875                            (*select-feature
1876                             (@ *streetmap* nearest-aux-points-layer)
1877                             (create render-intent "temporary"
1878                                     hover t
1879                                     highlight-only t)))))
1880          (setf (@ *streetmap* nearest-aux-points-select-control)
1881                (new (chain *open-layers
1882                            *control
1883                            (*select-feature
1884                             (@ *streetmap* nearest-aux-points-layer)))))
1885          (setf (@ *streetmap* aux-data-linestring-layer)
1886                (new (chain *open-layers
1887                            *layer
1888                            (*vector
1889                             "Aux Data Linestring"
1890                             (create
1891                              display-in-layer-switcher nil
1892                              style-map nearest-aux-point-layer-style-map
1893                              visibility t)))))
1894          (setf (@ *streetmap* google-streetmap-layer)
1895                (new (chain *open-layers
1896                            *layer
1897                            (*google "Google Streets"
1898                                     (create num-zoom-levels 23)))))
1899          (setf (@ *streetmap* osm-layer)
1900                (new (chain *open-layers
1901                            *layer
1902                            (*osm*
1903                             "OpenStreetMap"
1904                             nil
1905                             (create num-zoom-levels 23
1906                                     attribution
1907                                     "Data CC-By-SA by openstreetmap.org")))))
1908          (setf (@ *streetmap* overview-osm-layer)
1909                (new (chain *open-layers
1910                            *layer
1911                            (*osm* "OpenStreetMap"))))
1912          (setf (@ *streetmap* click-streetmap)
1913                (new (*click-control*
1914                      (create :trigger request-photos-after-click))))
1915          (setf (@ *streetmap* nirvana-layer)
1916                (new (chain
1917                      *open-layers
1918                      (*layer
1919                       "Nirvana"
1920                       (create is-base-layer t
1921                               projection (@ *streetmap* osm-layer projection)
1922                               max-extent (@ *streetmap* osm-layer max-extent)
1923                               max-resolution (@ *streetmap*
1924                                                 osm-layer
1925                                                 max-resolution)
1926                               units (@ *streetmap* osm-layer units)
1927                               num-zoom-levels (@ *streetmap*
1928                                                  osm-layer
1929                                                  num-zoom-levels))))))
1930          (chain *streetmap*
1931                 (add-control
1932                  (new (chain *open-layers
1933                              *control
1934                              (*layer-switcher
1935                               (create
1936                                div (chain
1937                                     document
1938                                     (get-element-by-id
1939                                      "streetmap-layer-switcher"))
1940                                rounded-corner nil))))))
1941          (let ((pan-west-control
1942                 (new (chain *open-layers *control (*pan "West"))))
1943                (pan-north-control
1944                 (new (chain *open-layers *control (*pan "North"))))
1945                (pan-south-control
1946                 (new (chain *open-layers *control (*pan "South"))))
1947                (pan-east-control
1948                 (new (chain *open-layers *control (*pan "East"))))
1949                (zoom-in-control
1950                 (new (chain *open-layers *control (*zoom-in))))
1951                (zoom-out-control
1952                 (new (chain *open-layers *control (*zoom-out))))
1953                (zoom-to-max-extent-control
1954                 (new (chain
1955                       *open-layers
1956                       *control
1957                       (*button
1958                        (create
1959                         display-class "streetmapZoomToMaxExtent"
1960                         trigger (lambda ()
1961                                   (chain *streetmap*
1962                                          (zoom-to-extent
1963                                           +presentation-project-bounds+ ))))))))
1964                (pan-zoom-panel
1965                 (new (chain *open-layers
1966                             *control
1967                             (*panel
1968                              (create div
1969                                      (chain
1970                                       document
1971                                       (get-element-by-id
1972                                        "streetmap-zoom")))))))
1973                (overview-map
1974                 (new (chain *open-layers
1975                             *control
1976                             (*overview-map
1977                              (create
1978
1979                               layers (array
1980                                       (@ *streetmap* overview-osm-layer)
1981                                       (@ *streetmap* overview-cursor-layer))
1982
1983                               min-ratio 14
1984                               max-ratio 16
1985                               div (chain document
1986                                          (get-element-by-id
1987                                           "streetmap-overview")))))))
1988                (mouse-position-control
1989                 (new (chain *open-layers
1990                             *control
1991                             (*mouse-position
1992                              (create div (chain document
1993                                                 (get-element-by-id
1994                                                  "streetmap-mouse-position"))
1995                                      empty-string "longitude, latitude")))))
1996                (scale-line-control
1997                 (new (chain *open-layers
1998                             *control
1999                             *scale-line))))
2000            (chain *streetmap*
2001                   (add-control pan-zoom-panel))
2002            (chain pan-zoom-panel
2003                   (add-controls (array pan-west-control
2004                                        pan-north-control
2005                                        pan-south-control
2006                                        pan-east-control
2007                                        zoom-in-control
2008                                        zoom-out-control
2009                                        zoom-to-max-extent-control)))
2010            (chain *streetmap*
2011                   (add-control (@ *streetmap* click-streetmap)))
2012            (chain *streetmap* click-streetmap (activate))
2013
2014            (chain *streetmap*
2015                   user-point-layer
2016                   events
2017                   (register "featureselected"
2018                             (@ *streetmap* user-point-layer)
2019                             user-point-selected))
2020            (chain *streetmap*
2021                   user-point-layer
2022                   events
2023                   (register "featureunselected"
2024                             (@ *streetmap* user-point-layer)
2025                             user-point-unselected))
2026            (chain *streetmap*
2027                   nearest-aux-points-layer
2028                   events
2029                   (register "featureselected"
2030                             (@ *streetmap* nearest-aux-points-layer)
2031                             nearest-aux-point-selected))
2032            (chain *streetmap*
2033                   (add-control
2034                    (@ *streetmap* nearest-aux-points-hover-control)))
2035            (chain *streetmap*
2036                   (add-control
2037                    (@ *streetmap* nearest-aux-points-select-control)))
2038            (chain *streetmap*
2039                   (add-control
2040                    (@ *streetmap* user-points-hover-control)))
2041            (chain *streetmap*
2042                   (add-control
2043                    (@ *streetmap* user-points-select-control)))
2044            (chain *streetmap* user-points-hover-control (activate))
2045            (chain *streetmap* user-points-select-control (activate))
2046            (chain *streetmap* nearest-aux-points-hover-control (activate))
2047            (chain *streetmap* nearest-aux-points-select-control (activate))
2048            (chain *streetmap* (add-layer (@ *streetmap* osm-layer)))
2049            (try (chain *streetmap*
2050                        (add-layer (@ *streetmap* google-streetmap-layer)))
2051                 (:catch (c)
2052                   (chain *streetmap*
2053                          (remove-layer (@ *streetmap*
2054                                           google-streetmap-layer)))))
2055            (chain *streetmap* (add-layer (@ *streetmap* nirvana-layer)))
2056            (chain *streetmap*
2057                   (add-layer (@ *streetmap* nearest-aux-points-layer)))
2058            (chain *streetmap* (add-layer (@ *streetmap* survey-layer)))
2059            (chain *streetmap*
2060                   (add-layer (@ *streetmap* cursor-layer)))
2061            (chain *streetmap*
2062                   (add-layer (@ *streetmap* aux-point-layer)))
2063            (chain *streetmap*
2064                   (add-layer (@ *streetmap* aux-data-linestring-layer)))
2065            (chain *streetmap*
2066                   (add-layer (@ *streetmap* user-point-layer)))
2067            (setf (@ overview-map element)
2068                  (chain document (get-element-by-id
2069                                   "streetmap-overview-element")))
2070            (chain *streetmap* (add-control overview-map))
2071            (chain *streetmap* (add-control mouse-position-control))
2072            (chain *streetmap* (add-control scale-line-control)))
2073          (loop
2074             for i from 0 below (lisp *number-of-images*)
2075             do (initialize-image i))
2076          (add-help-events)
2077          (chain *streetmap*
2078                 (zoom-to-extent
2079                  (if (lisp (stored-bbox))
2080                      (new (chain *open-layers
2081                              *bounds
2082                              (from-string (lisp (stored-bbox)))
2083                              (transform +geographic+ +spherical-mercator+)))
2084                      +presentation-project-bounds+)))
2085            (let ((stored-cursor (lisp (stored-cursor))))
2086              (when stored-cursor
2087                (request-photos
2088                 (new (chain *open-layers
2089                             *lon-lat
2090                             (from-string stored-cursor)
2091                             (transform +geographic+
2092                                        +spherical-mercator+)))))))))))
2093
2094 (pushnew (hunchentoot:create-regex-dispatcher
2095           (format nil "/phoros/lib/phoros-~A-\\S*-\\S*\.js"
2096                   (phoros-version))
2097           'phoros.js)
2098          hunchentoot:*dispatch-table*)