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