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