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 (define-easy-handler (phoros.js :uri "/phoros-lib/phoros.js") ()
  21   "Serve some Javascript."
  22   (when (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           :h2-controls
  51           (who-ps-html
  52            (:p "Current action."))
  53           :multiple-points-phoros-controls
  54           (who-ps-html
  55            (:p "Try reading the text under mouse pointer."))
  56           :finish-point-button
  57           (who-ps-html
  58            (:p "Store point with its attribute, description and
  59            numeric description into database.  Afterwards, increment
  60            the numeric description if possible."))
  61           :delete-point-button
  62           (who-ps-html
  63            (:p "Delete current point."))
  64           :download-user-points-button
  65           (who-ps-html
  66            (:p "Download all user points as GeoJSON-fomatted text file."))
  67           :point-attribute
  68           (who-ps-html
  69            (:p "One of a few possible user point attributes.")
  70            (:p "TODO: currently only the hard-coded ones are available."))
  71           :point-description
  72           (who-ps-html
  73            (:p "Optional verbal description of user point."))
  74           :point-numeric-description
  75           (who-ps-html
  76            (:p "Optional additional description of user point.  If
  77            parts of it looks like a number, the leftmost such part is
  78            automatically incremented during click into first image."))
  79           :point-creation-date
  80           (who-ps-html
  81            (:p "Creation date of current user point.  Will be updated
  82            when you change this point."))
  83           :include-aux-data-p
  84           (who-ps-html
  85            (:p "Check this if the user point being created should
  86            include auxiliary data."))
  87           :aux-point-distance
  88           (who-ps-html
  89            (:p "Select a set of auxiliary data, either by its distance
  90            from the current estimated position, or by clicking its
  91            representation in streetmap.")
  92            (:p "TODO:  This is not a decent length unit."))
  93           :aux-data
  94           (who-ps-html
  95            (:p "Auxiliary data connected to this presentation project;
  96            all the numeric values followed by all the text values if
  97            any."))
  98           :creator
  99           (who-ps-html
 100            (:p "Creator of current user point.  Will be updated when
 101            you change this point."))
 102           :remove-work-layers-button
 103           (who-ps-html
 104            (:p "Discard the current, unstored user point or unselect
 105            currently selected user points.  Zoom out all images. Keep
 106            the rest of the workspace untouched."))
 107           :blurb-button
 108           (who-ps-html
 109            (:p "View some info about Phoros."))
 110           :logout-button
 111           (who-ps-html
 112            (:p "Finish this session.  Fresh login is required to
 113            continue."))
 114           :streetmap
 115           (who-ps-html
 116            (:p "Clicking into the streetmap fetches images which most
 117            probably feature the clicked point.")
 118            (:p "TODO: This is not quite so.  Currently images taken
 119            from points nearest to the clicked one are displayed.")
 120            (:p "To pan the map, drag the mouse.  To zoom, spin the
 121            mouse wheel, or hold shift down whilst dragging a box, or
 122            double-click (shift double-click for larger zoom steps) a
 123            point of interest."))
 124           :image
 125           (who-ps-html
 126            (:p "Clicking into an image sets or resets the active point
 127            there.  Once a feature is marked by active points in more
 128            than one image, the estimated position is calculated.")
 129            (:p "To pan an image, drag the mouse.  To zoom, spin the
 130            mouse wheel, or hold shift down whilst dragging a box, or
 131            double-click (shift double-click for larger zoom steps) a
 132            point of interest."))
 133           ol-Control-Pan-West-Item-Inactive
 134           (who-ps-html
 135            (:p "Move viewport left."))
 136           ol-Control-Pan-East-Item-Inactive
 137           (who-ps-html
 138            (:p "Move viewport right."))
 139           ol-Control-Pan-North-Item-Inactive
 140           (who-ps-html
 141            (:p "Move viewport up."))
 142           ol-Control-Pan-South-Item-Inactive
 143           (who-ps-html
 144            (:p "Move viewport down."))
 145           ol-Control-Zoom-In-Item-Inactive
 146           (who-ps-html
 147            (:p "Zoom in."))
 148           ol-Control-Zoom-Out-Item-Inactive
 149           (who-ps-html
 150            (:p "Zoom out."))
 151           streetmap-Zoom-To-Max-Extent-Item-Inactive
 152           (who-ps-html
 153            (:p "Zoom to the extent of presentation project."))
 154           ol-Control-Zoom-To-Max-Extent-Item-Inactive
 155           (who-ps-html
 156            (:p "Zoom out completely, restoring the original view."))
 157           :zoom-images-to-max-extent
 158           (who-ps-html
 159            (:p "Zoom all images out completely, restoring the original
 160            view."))
 161           :auto-zoom
 162           (who-ps-html
 163            (:p "Check this to automatically zoom into images once they
 164            get an estimated position."))
 165           :image-layer-switcher
 166           (who-ps-html
 167            (:p "Toggle display of image."))
 168           :image-trigger-time
 169           (who-ps-html
 170            (:p "Time this image was taken."))
 171           base-layers-div
 172           (who-ps-html
 173            (:p "Choose a background streetmap."))
 174           data-layers-div
 175           (who-ps-html
 176            (:p "Toggle visibility of data layers."))
 177           :streetmap-overview
 178           (who-ps-html
 179            (:p "Click to re-center streetmap, or drag the red rectangle."))
 180           :streetmap-mouse-position
 181           (who-ps-html
 182            (:p "Cursor position in geographic coordinates when cursor
 183            is in streetmap."))
 184           :h2-help
 185           (who-ps-html
 186            (:p "Hints on Phoros' displays and controls are shown here
 187            while hovering over the respective elements."))))
 188
 189        (defun add-help-topic (topic element)
 190          "Add mouse events to DOM element that initiate display of a
 191          help message."
 192          (when element
 193            (setf (@ element onmouseover)
 194                  ((lambda (x)
 195                     (lambda () (show-help x)))
 196                   topic))
 197            (setf (@ element onmouseout) show-help)))
 198
 199        (defun add-help-events ()
 200          "Add mouse events to DOM elements that initiate display of a
 201          help message."
 202          (for-in
 203           (topic *help-topics*)
 204           (add-help-topic topic (chain document (get-element-by-id topic)))
 205           (dolist (element (chain document (get-elements-by-class-name topic)))
 206             (add-help-topic topic element))))
 207
 208        (defun show-help (&optional topic)
 209          "Put text on topic into help-display"
 210          (setf (inner-html-with-id "help-display")
 211                (let ((help-body (getprop *help-topics* topic)))
 212                  (if (undefined help-body)
 213                      ""
 214                      help-body))))
 215
 216        (defvar *click-control*
 217          (chain
 218           *open-layers
 219           (*class
 220            (@ *open-layers *control)
 221            (create
 222             :default-handler-options
 223             (create :single t
 224                     :double false
 225                     :pixel-tolerance 0
 226                     :stop-single false
 227                     :stop-double false)
 228             :initialize
 229             (lambda (options)
 230               (setf
 231                (@ this handler-options)
 232                (chain *open-layers
 233                       *util
 234                       (extend
 235                        (create)
 236                        (@ this default-handler-options))))
 237               (chain *open-layers
 238                      *control
 239                      prototype
 240                      initialize
 241                      (apply this arguments))
 242               (setf (@ this handler)
 243                     (new (chain *open-layers
 244                                 *handler
 245                                 (*click this
 246                                         (create
 247                                          :click (@ this trigger))
 248                                         (@ this handler-options))))))))))
 249
 250        (defvar +unix-epoch+ (lisp *unix-epoch*)
 251          "Seconds between Lisp epoch and UNIX epoch.")
 252        (defvar +geographic+
 253          (new (chain *open-layers (*projection "EPSG:4326"))))
 254        (defvar +spherical-mercator+
 255          (new (chain *open-layers (*projection "EPSG:900913"))))
 256
 257        (defvar +user-name+ (lisp (session-value 'user-name))
 258          "User's (short) name")
 259        (defvar +user-role+ (lisp (string-downcase (session-value 'user-role)))
 260          "User's permissions")
 261
 262        (defvar +presentation-project-bounds+
 263          (chain (new (chain *open-layers
 264                             *bounds
 265                             (from-string
 266                              (lisp (session-value 'presentation-project-bbox)))))
 267                 (transform +geographic+ +spherical-mercator+))
 268          "Bounding box of the entire presentation project.")
 269
 270        (defvar *images* (array) "Collection of the photos currently shown.")
 271
 272        (defvar *streetmap* undefined
 273          "The streetmap shown to the user.")
 274
 275        (defvar *streetmap-estimated-position-layer*)
 276
 277        (defvar *point-attributes-select* undefined
 278          "The HTML element for selecting user point attributes.")
 279
 280        (defvar *aux-point-distance-select* undefined
 281          "The HTML element for selecting one of a few nearest auxiliary points.")
 282
 283        (defvar *global-position* undefined
 284          "Coordinates of the current estimated position")
 285
 286        (defvar *current-nearest-aux-point*
 287          (create attributes (create aux-numeric undefined
 288                                     aux-text undefined))
 289          "Attributes of currently selected point of auxiliary data.")
 290
 291
 292        (defvar *bbox-strategy* (chain *open-layers *strategy *bbox*))
 293        (setf (chain *bbox-strategy* prototype ratio) 1.5)
 294        (setf (chain *bbox-strategy* prototype res-factor) 1.5)
 295
 296        (defvar *json-parser* (new (chain *open-layers *format *json*)))
 297
 298        (defvar *geojson-format* (chain *open-layers *format *geo-j-s-o-n))
 299        (setf (chain *geojson-format* prototype ignore-extra-dims)
 300         t)                              ;doesn't handle height anyway
 301        (setf (chain *geojson-format* prototype external-projection)
 302         +geographic+)
 303        (setf (chain *geojson-format* prototype internal-projection)
 304         +geographic+)
 305
 306        (defvar *http-protocol* (chain *open-layers *protocol *http*))
 307        (setf (chain *http-protocol* prototype format) (new *geojson-format*))
 308
 309        (defvar *survey-layer*
 310          (let ((survey-layer-style
 311                 (create stroke-color (chain *open-layers *feature *vector
 312                                             style "default" stroke-color)
 313                         stroke-width 1
 314                         point-radius 2
 315                         fill-opacity 0
 316                         graphic-name "circle")))
 317            (new (chain
 318                  *open-layers *layer
 319                  (*vector
 320                   "survey"
 321                   (create
 322                    strategies (array (new (*bbox-strategy*)))
 323                    protocol
 324                    (new (*http-protocol*
 325                          (create :url "/phoros-lib/points.json")))
 326                    style survey-layer-style
 327                    ))))))
 328
 329        (defvar *user-point-layer*
 330          (new (chain
 331                *open-layers *layer
 332                (*vector
 333                 "user points"
 334                 (create
 335                  strategies (array (new *bbox-strategy*))
 336                  protocol
 337                  (new (*http-protocol*
 338                        (create :url "/phoros-lib/user-points.json")))
 339                  style-map (user-point-style-map nil))))))
 340
 341        (defvar *aux-point-layer*
 342          (let ((aux-layer-style
 343                 (create stroke-color "grey"
 344                         stroke-width 1
 345                         point-radius 2
 346                         fill-opacity 0
 347                         graphic-name "circle")))
 348            (new (chain
 349                  *open-layers *layer
 350                  (*vector
 351                   "auxiliary data"
 352                   (create
 353                    strategies (array (new (*bbox-strategy*)))
 354                    protocol
 355                    (new (*http-protocol*
 356                          (create :url "/phoros-lib/aux-points.json")))
 357                    style aux-layer-style
 358                    visibility nil))))))
 359
 360        (defvar *streetmap-nearest-aux-points-layer*
 361          (let ((nearest-aux-point-layer-style-map
 362                 (new (chain *open-layers
 363                             (*style-map
 364                              (create "default"
 365                                      (create stroke-color "grey"
 366                                              stroke-width 1
 367                                              point-radius 5
 368                                              fill-opacity 0
 369                                              graphic-name "circle")
 370                                      "select"
 371                                      (create stroke-color "black"
 372                                              stroke-width 1
 373                                              point-radius 5
 374                                              fill-opacity 0
 375                                              graphic-name "circle")
 376                                      "temporary"
 377                                      (create stroke-color "grey"
 378                                              stroke-width 1
 379                                              point-radius 5
 380                                              fill-color "grey"
 381                                              fill-opacity 1
 382                                              graphic-name "circle")))))))
 383            (new (chain *open-layers
 384                        *layer
 385                        (*vector "Nearest Aux Points"
 386                                 (create
 387                                  display-in-layer-switcher nil
 388                                  style-map nearest-aux-point-layer-style-map
 389                                  visibility t))))))
 390
 391        (defvar *nearest-aux-points-hover-control*
 392          (new (chain *open-layers
 393                      *control
 394                      (*select-feature *streetmap-nearest-aux-points-layer*
 395                                       (create render-intent "temporary"
 396                                               hover t
 397                                               highlight-only t)))))
 398
 399        (defvar *nearest-aux-points-select-control*
 400          (new (chain *open-layers
 401                      *control
 402                      (*select-feature *streetmap-nearest-aux-points-layer*))))
 403
 404        (defvar *pristine-images-p* t
 405          "T if none of the current images has been clicked into yet.")
 406
 407        (defvar *current-user-point* undefined
 408          "The currently selected user-point.")
 409
 410        (defvar *user-points-hover-control*
 411          (new (chain *open-layers
 412                      *control
 413                      (*select-feature *user-point-layer*
 414                                       (create render-intent "temporary"
 415                                               hover t
 416                                               highlight-only t)))))
 417
 418        (defvar *user-points-select-control*
 419          (new (chain *open-layers
 420                      *control
 421                      (*select-feature *user-point-layer*
 422                                       (create toggle t
 423                                               multiple t)))))
 424
 425        (defvar *google-streetmap-layer*
 426          (new (chain *open-layers
 427                      *layer
 428                      (*google "Google Streets"
 429                               (create num-zoom-levels 22)))))
 430
 431        (defvar *osm-layer*
 432          (new (chain *open-layers
 433                      *layer
 434                      (*osm* "OpenStreetMap"
 435                             nil (create num-zoom-levels 19)))))
 436
 437        (defvar *click-streetmap*
 438          (new (*click-control* (create :trigger request-photos))))
 439
 440        (defun write-permission-p (&optional (current-owner +user-name+))
 441          "Nil if current user can't edit stuff created by
 442 current-owner or, without arguments, new stuff."
 443          (or (== +user-role+ "admin")
 444              (and (== +user-role+ "write")
 445                   (== +user-name+ current-owner))))
 446
 447        (defun *image ()
 448          "Anything necessary to deal with a photo."
 449          (setf (getprop this 'map)
 450                (new ((getprop *open-layers '*map)
 451                      (create projection +spherical-mercator+
 452                              all-overlays t
 453                              controls (array (new (chain *open-layers
 454                                                          *control
 455                                                          (*navigation))))))))
 456          (setf (getprop this 'dummy) false) ;TODO why? (omitting splices map components directly into *image)
 457          )
 458
 459        (setf (getprop *image 'prototype 'show-photo)
 460         show-photo)
 461        (setf (getprop *image 'prototype 'draw-epipolar-line)
 462         draw-epipolar-line)
 463        (setf (getprop *image 'prototype 'draw-active-point)
 464         draw-active-point)
 465        (setf (getprop *image 'prototype 'draw-estimated-positions)
 466         draw-estimated-positions)
 467
 468        (defun photo-path (photo-parameters)
 469          "Create from stuff found in photo-parameters a path for use in
 470 an image url."
 471          (+ "/phoros-lib/photo/" (@ photo-parameters directory) "/"
 472             (@ photo-parameters filename) "/"
 473             (@ photo-parameters byte-position) ".png"))
 474
 475        (defun has-layer-p (map layer-name)
 476          "False if map doesn't have a layer called layer-name."
 477          (chain map (get-layers-by-name layer-name) length))
 478
 479        (defun some-active-point-p ()
 480          "False if no image in *images* has an Active Point."
 481          (loop
 482             for i across *images*
 483             sum (has-layer-p (getprop i 'map) "Active Point")))
 484
 485        (defun remove-layer (map layer-name)
 486          "Destroy layer layer-name in map."
 487          (when (has-layer-p map layer-name)
 488            (chain map (get-layers-by-name layer-name) 0 (destroy))))
 489
 490        (defun remove-any-layers (layer-name)
 491          "Destroy in all *images* and in *streetmap* the layer named layer-name."
 492          (loop
 493             for i across *images* do
 494               (remove-layer (getprop i 'map) layer-name))
 495          (remove-layer *streetmap* layer-name))
 496
 497        (defun reset-controls ()
 498          (reveal-element-with-id "real-phoros-controls")
 499          (hide-element-with-id "multiple-points-phoros-controls")
 500          (disable-element-with-id "finish-point-button")
 501          (disable-element-with-id "delete-point-button")
 502          (disable-element-with-id "remove-work-layers-button")
 503          (setf (inner-html-with-id "h2-controls") "Create Point")
 504          (setf (inner-html-with-id "creator") nil)
 505          (setf (inner-html-with-id "point-creation-date") nil)
 506          (hide-aux-data-choice)
 507          (setf (inner-html-with-id "aux-numeric-list") nil)
 508          (setf (inner-html-with-id "aux-text-list") nil))
 509
 510        (defun disable-streetmap-nearest-aux-points-layer ()
 511          "Get *streetmap-nearest-aux-points-layer* out of the way,
 512 I.e., remove features and disable feature select control so it won't
 513 shadow any other control."
 514          (chain *streetmap-nearest-aux-points-layer* (remove-all-features))
 515          (chain *nearest-aux-points-select-control* (deactivate))
 516          (chain *user-points-select-control* (activate)))
 517
 518        (defun reset-layers-and-controls ()
 519          "Destroy user-generated layers in *streetmap* and in all
 520 *images*, and put controls into pristine state."
 521          (remove-any-layers "Epipolar Line")
 522          (remove-any-layers "Active Point")
 523          (remove-any-layers "Estimated Position")
 524          (remove-any-layers "User Point")
 525          (chain *user-points-select-control* (unselect-all))
 526          (disable-streetmap-nearest-aux-points-layer)
 527          (when (and (!= undefined *current-user-point*)
 528                     (chain *current-user-point* layer))
 529            (chain *user-points-select-control*
 530                   (unselect *current-user-point*)))
 531          (reset-controls)
 532          (setf *pristine-images-p* t)
 533          (zoom-images-to-max-extent))
 534
 535        (defun enable-element-with-id (id)
 536          "Activate HTML element with id=\"id\"."
 537          (setf (chain document (get-element-by-id id) disabled) nil))
 538
 539        (defun disable-element-with-id (id)
 540          "Grey out HTML element with id=\"id\"."
 541          (setf (chain document (get-element-by-id id) disabled) t))
 542
 543        (defun hide-element-with-id (id)
 544          "Hide HTML element wit id=\"id\"."
 545          (setf (chain document (get-element-by-id id) style display)
 546                "none"))
 547
 548        (defun reveal-element-with-id (id)
 549          "Reveal HTML element wit id=\"id\"."
 550          (setf (chain document (get-element-by-id id) style display)
 551                ""))
 552
 553        (defun hide-aux-data-choice ()
 554          "Disable selector for auxiliary data."
 555          ;;(disable-element-with-id "include-aux-data-p")
 556          (hide-element-with-id "include-aux-data-p")
 557          (hide-element-with-id "aux-point-distance")
 558          (setf (chain document
 559                       (get-element-by-id "aux-point-distance")
 560                       options
 561                       length)
 562                0))
 563
 564        (defun refresh-layer (layer)
 565          "Have layer re-request and redraw features."
 566          (chain layer (refresh (create :force t))))
 567
 568        (defun present-photos ()
 569          "Handle the response triggered by request-photos."
 570          (let ((photo-parameters
 571                 (chain *json-parser*
 572                        (read (@ photo-request-response response-text)))))
 573            (loop
 574               for p across photo-parameters
 575               for i across *images*
 576               do
 577                 (setf (getprop i 'photo-parameters) p)
 578                 ((getprop i 'show-photo)))
 579            ;; (setf (@ (aref photo-parameters 0) angle180) 1) ; Debug: coordinate flipping
 580            ))
 581
 582        (defun request-photos (event)
 583          "Handle the response to a click into *streetmap*; fetch photo data."
 584          (disable-element-with-id "finish-point-button")
 585          (disable-element-with-id "remove-work-layers-button")
 586          (remove-any-layers "Estimated Position")
 587          (disable-streetmap-nearest-aux-points-layer)
 588          (reset-controls)
 589          (let* ((lonlat
 590                  (chain *streetmap*
 591                         (get-lon-lat-from-pixel (@ event xy))
 592                         (transform +spherical-mercator+
 593                                    +geographic+)))
 594                 (content
 595                  (chain *json-parser*
 596                         (write
 597                          (create :longitude (@ lonlat lon)
 598                                  :latitude (@ lonlat lat)
 599                                  :zoom ((@ *streetmap* get-zoom))
 600                                  :count (lisp *number-of-images*))))))
 601            (setf photo-request-response
 602                  ((@ *open-layers *Request *POST*)
 603                   (create :url "/phoros-lib/local-data"
 604                           :data content
 605                           :headers (create "Content-type" "text/plain"
 606                                            "Content-length" (@ content length))
 607                           :success present-photos)))))
 608
 609        (defun draw-epipolar-line ()
 610          "Draw an epipolar line from response triggered by clicking
 611 into a (first) photo."
 612          (enable-element-with-id "remove-work-layers-button")
 613          (let* ((epipolar-line
 614                  (chain *json-parser*
 615                         (read
 616                          (@ this epipolar-request-response response-text))))
 617                 (points
 618                  (chain epipolar-line
 619                         (map (lambda (x)
 620                                (new (chain *open-layers *geometry (*point
 621                                      (@ x :m) (@ x :n))))))))
 622                 (feature
 623                  (new (chain *open-layers
 624                              *feature
 625                              (*vector
 626                               (new (chain
 627                                     *open-layers
 628                                     *geometry
 629                                     (*line-string points))))))))
 630            (setf (chain feature render-intent) "temporary")
 631            (chain this epipolar-layer
 632                   (add-features feature))))
 633        ;; either *line-string or *multi-point are usable
 634
 635        (defun request-nearest-aux-points (global-position count)
 636          "Draw into streetmap the count nearest points of auxiliary
 637 data."
 638          (let ((global-position-etc global-position)
 639                content)
 640            (setf (chain global-position-etc count) count)
 641            (setf content (chain *json-parser*
 642                                 (write global-position-etc)))
 643            (setf (@ *streetmap* aux-local-data-request-response)
 644                  ((@ *open-layers *Request *POST*)
 645                   (create :url "/phoros-lib/aux-local-data"
 646                           :data content
 647                           :headers (create "Content-type" "text/plain"
 648                                            "Content-length"
 649                                            (@ content length))
 650                           :success draw-nearest-aux-points)))))
 651
 652        (defun draw-estimated-positions ()
 653          "Draw into streetmap and into all images points at Estimated
 654 Position.  Estimated Position is the point returned so far from
 655 photogrammetric calculations that are triggered by clicking into
 656 another photo.  Also draw into streetmap the nearest auxiliary points
 657 to Estimated Position."
 658          (when (write-permission-p)
 659            (setf (chain document
 660                         (get-element-by-id "finish-point-button")
 661                         onclick)
 662                  finish-point)
 663            (enable-element-with-id "finish-point-button"))
 664          (let* ((estimated-positions-request-response
 665                  (chain *json-parser*
 666                         (read
 667                          (getprop this
 668                                   'estimated-positions-request-response
 669                                   'response-text))))
 670                 (estimated-positions
 671                  (aref estimated-positions-request-response 1))
 672                 (estimated-position-style
 673                  (create stroke-color (chain *open-layers *feature *vector
 674                                              style "temporary" stroke-color)
 675                          point-radius 9
 676                          fill-opacity 0)))
 677            (setf *global-position*
 678                  (aref estimated-positions-request-response 0))
 679            (let ((feature
 680                   (new ((@ *open-layers *feature *vector)
 681                         ((@ (new ((@ *open-layers *geometry *point)
 682                                   (getprop *global-position* 'longitude)
 683                                   (getprop *global-position* 'latitude)))
 684                             transform) +geographic+ +spherical-mercator+)))))
 685              (setf (chain feature render-intent) "temporary")
 686              (setf *streetmap-estimated-position-layer*
 687                    (new (chain *open-layers
 688                                *layer
 689                                (*vector "Estimated Position"
 690                                         (create display-in-layer-switcher nil)))))
 691              (setf (chain *streetmap-estimated-position-layer* style)
 692                    estimated-position-style)
 693              (chain *streetmap-estimated-position-layer*
 694                     (add-features feature))
 695              (chain *streetmap*
 696                     (add-layer *streetmap-estimated-position-layer*)))
 697            (request-nearest-aux-points *global-position* 5)
 698            (loop
 699               for i in *images*
 700               for p in estimated-positions
 701               do
 702                 (when i    ;otherwise a photogrammetry error has occured
 703                   (setf (@ i estimated-position-layer)
 704                         (new
 705                          (chain *open-layers *layer
 706                                 (*vector "Estimated Position"
 707                                          (create display-in-layer-switcher nil)))))
 708                   (setf (chain i estimated-position-lonlat)
 709                         (new (chain *open-layers (*lon-lat
 710                                                   (getprop p 'm)
 711                                                   (getprop p 'n)))))
 712                   (setf (chain i estimated-position-layer style)
 713                         estimated-position-style)
 714                   (let* ((point
 715                           (new
 716                            (chain *open-layers *geometry (*point
 717                                                           (getprop p 'm)
 718                                                           (getprop p 'n)))))
 719                          (feature
 720                           (new
 721                            (chain *open-layers *feature (*vector point)))))
 722                     (chain i map
 723                            (add-layer (@ i estimated-position-layer)))
 724                     (chain i estimated-position-layer
 725                            (add-features feature))))))
 726          (zoom-anything-to-point))
 727
 728        (defun draw-nearest-aux-points ()
 729          "Draw a few auxiliary points into streetmap."
 730          (reveal-element-with-id "include-aux-data-p")
 731          (reveal-element-with-id "aux-point-distance")
 732          (let ((features
 733                 (chain *json-parser*
 734                        (read
 735                         (getprop *streetmap*
 736                                  'aux-local-data-request-response
 737                                  'response-text))
 738                        features)))
 739            (disable-streetmap-nearest-aux-points-layer)
 740            (chain *user-points-select-control* (deactivate))
 741            (chain *nearest-aux-points-select-control* (activate))
 742            (chain *nearest-aux-points-hover-control* (activate))
 743            (setf (chain *aux-point-distance-select*
 744                         options
 745                         length)
 746                  0)
 747            (loop
 748               for i in features
 749               for n from 0 do
 750                 (let* ((point
 751                         (chain
 752                          (new
 753                           (chain *open-layers
 754                                  *geometry
 755                                  (*point (chain i geometry coordinates 0)
 756                                          (chain i geometry coordinates 1))))
 757                          (transform +geographic+ +spherical-mercator+)))
 758                        (feature
 759                         (new
 760                          (chain *open-layers *feature (*vector point)))))
 761                   (setf (chain feature attributes)
 762                         (chain i properties))
 763                   (setf (chain feature fid) ;this is supposed to correspond to
 764                         n)                  ; option of *aux-point-distance-select*
 765                   (chain *streetmap-nearest-aux-points-layer*
 766                          (add-features feature))
 767                   (setf aux-point-distance-item
 768                         (chain document (create-element "option")))
 769                   (setf (chain aux-point-distance-item text)
 770                         (+
 771                          "("
 772                          n ;let's hope add-features alway stores features in order of arrival
 773                          ") "
 774                          (chain i properties distance)))
 775                   (chain *aux-point-distance-select*
 776                          (add aux-point-distance-item null))))
 777            (chain *nearest-aux-points-select-control*
 778                   (select
 779                    (chain
 780                     (elt (chain *streetmap-nearest-aux-points-layer* features)
 781                          0))))
 782            (enable-element-with-id "aux-point-distance")))
 783
 784        (defun user-point-style-map (label-property)
 785          "Create a style map where styles dispatch on feature property
 786          \"attribute\" and features are labelled after feature
 787          property label-property."
 788          (let* ((symbolizer-property "attribute")
 789                 (solitary-filter
 790                  (new (chain *open-layers
 791                              *filter
 792                              (*comparison (create type (chain *open-layers
 793                                                               *filter
 794                                                               *comparison
 795                                                               *like*)
 796                                                   property symbolizer-property
 797                                                   value "solitary")))))
 798                 (polyline-filter
 799                  (new (chain *open-layers
 800                              *filter
 801                              (*comparison (create type (chain *open-layers
 802                                                               *filter
 803                                                               *comparison
 804                                                               *like*)
 805                                                   property symbolizer-property
 806                                                   value "polyline")))))
 807                 (polygon-filter
 808                  (new (chain *open-layers
 809                              *filter
 810                              (*comparison (create type (chain *open-layers
 811                                                               *filter
 812                                                               *comparison
 813                                                               *like*)
 814                                                   property symbolizer-property
 815                                                   value "polygon")))))
 816                 (solitary-rule
 817                  (new (chain *open-layers
 818                              (*rule (create
 819                                      filter solitary-filter
 820                                      symbolizer (create
 821                                                  graphic-name "triangle"))))))
 822                 (polyline-rule
 823                  (new (chain *open-layers
 824                              (*rule (create
 825                                      filter polyline-filter
 826                                      symbolizer (create
 827                                                  graphic-name "square"))))))
 828                 (polygon-rule
 829                  (new (chain *open-layers
 830                              (*rule (create
 831                                      filter polygon-filter
 832                                      symbolizer (create
 833                                                  graphic-name "star"))))))
 834                 (else-rule
 835                  (new (chain *open-layers
 836                              (*rule (create
 837                                      else-filter t
 838                                      symbolizer (create
 839                                                  graphic-name "x"))))))
 840                 (user-point-default-style
 841                  (new (chain
 842                        *open-layers
 843                        (*style (create stroke-color "OrangeRed"
 844                                        fill-color "OrangeRed"
 845                                        stroke-opacity .5
 846                                        stroke-width 2
 847                                        point-radius 5
 848                                        fill-opacity 0)
 849                                (create rules (array solitary-rule
 850                                                     polyline-rule
 851                                                     polygon-rule
 852                                                     else-rule))))))
 853                 (user-point-select-style
 854                  (new (chain
 855                        *open-layers
 856                        (*style (create stroke-opacity 1
 857                                        label label-property)
 858                                (create rules (array solitary-rule
 859                                                     polyline-rule
 860                                                     polygon-rule
 861                                                     else-rule))))))
 862                 (user-point-temporary-style
 863                  (new (chain
 864                        *open-layers
 865                        (*style (create fill-opacity .5)
 866                                (create rules (array solitary-rule
 867                                                     polyline-rule
 868                                                     polygon-rule
 869                                                     else-rule)))))))
 870            (new (chain *open-layers
 871                        (*style-map
 872                         (create "default" user-point-default-style
 873                                 "temporary" user-point-temporary-style
 874                                 "select" user-point-select-style))))))
 875
 876        (defun draw-user-point ()        ;TODO: we may draw more than one point; change name
 877          "Draw currently selected user point into all images."
 878          (let* ((user-point-positions-response
 879                  (chain *json-parser*
 880                         (read
 881                          (getprop *user-point-in-images-response*
 882                                   'response-text))))
 883                 (user-point-collections
 884                  (chain user-point-positions-response image-points))
 885                 (user-point-count
 886                  (chain user-point-positions-response user-point-count))
 887                 (label
 888                  (when (> user-point-count 1) "${numericDescription}")))
 889            (loop
 890               for i in *images*
 891               for user-point-collection in user-point-collections
 892               do
 893                 (when i  ;otherwise a photogrammetry error has occured
 894                   (let ((features
 895                          (loop
 896                             for raw-feature in
 897                             (chain user-point-collection features)
 898                             collect
 899                             (let* ((x
 900                                     (chain raw-feature geometry coordinates 0))
 901                                    (y
 902                                     (chain raw-feature geometry coordinates 1))
 903                                    (point
 904                                     (new (chain *open-layers
 905                                                 *geometry
 906                                                 (*point x y))))
 907                                    (fid
 908                                     (chain raw-feature id))
 909                                    (attributes
 910                                     (chain raw-feature properties))
 911                                    (feature
 912                                     (new (chain *open-layers
 913                                                 *feature
 914                                                 (*vector point attributes)))))
 915                               (setf (chain feature fid) fid)
 916                               (setf (chain feature render-intent) "select")
 917                               feature))))
 918                     (setf
 919                      (@ i user-point-layer)
 920                      (new (chain *open-layers
 921                                  *layer
 922                                  (*vector
 923                                   "User Point"
 924                                   (create display-in-layer-switcher nil
 925                                           style-map (user-point-style-map
 926                                                      label))))))
 927                     (chain i map (add-layer (@ i user-point-layer)))
 928                     (chain i user-point-layer (add-features features)))))))
 929
 930        (defun finish-point ()
 931          "Send current *global-position* as a user point to the database."
 932          (let ((global-position-etc *global-position*))
 933            (setf (chain global-position-etc attribute)
 934                  (chain
 935                   (elt (chain *point-attributes-select* options)
 936                        (chain *point-attributes-select* options selected-index))
 937                   text))
 938            (setf (chain global-position-etc description)
 939                  (value-with-id "point-description"))
 940            (setf (chain global-position-etc numeric-description)
 941                  (value-with-id "point-numeric-description"))
 942            (when (checkbox-status-with-id "include-aux-data-p")
 943              (setf (chain global-position-etc aux-numeric)
 944                    (chain *current-nearest-aux-point*
 945                           attributes
 946                           aux-numeric))
 947              (setf (chain global-position-etc aux-text)
 948                    (chain *current-nearest-aux-point*
 949                           attributes
 950                           aux-text)))
 951            (let ((content
 952                   (chain *json-parser*
 953                          (write global-position-etc))))
 954              ((@ *open-layers *Request *POST*)
 955               (create :url "/phoros-lib/store-point"
 956                       :data content
 957                       :headers (create "Content-type" "text/plain"
 958                                        "Content-length" (@ content length))
 959                       :success (lambda ()
 960                                  (refresh-layer *user-point-layer*)
 961                                  (reset-layers-and-controls)))))))
 962
 963        (defun increment-numeric-text (text)
 964          "Increment text if it looks like a number, and return it."
 965          (let* ((parts (chain (regex "(\\D*)(\\d*)(.*)") (exec text)))
 966                 (old-number (elt parts 2))
 967                 (new-number (1+ (parse-int old-number 10)))))
 968            (if (is-finite new-number)
 969                (+ (elt parts 1) new-number (elt parts 3))
 970                text))
 971
 972        (defun update-point ()
 973          "Send changes to currently selected user point to database."
 974          (let* ((point-data
 975                  (create user-point-id (chain *current-user-point* fid)
 976                          attribute
 977                          (chain
 978                           (elt (chain *point-attributes-select*
 979                                       options)
 980                                (chain *point-attributes-select*
 981                                       options
 982                                       selected-index))
 983                           text)
 984                          description
 985                          (value-with-id "point-description")
 986                          numeric-description
 987                          (value-with-id "point-numeric-description")))
 988                 (content
 989                  (chain *json-parser*
 990                         (write point-data))))
 991            ((@ *open-layers *Request *POST*)
 992             (create :url "/phoros-lib/update-point"
 993                     :data content
 994                     :headers (create "Content-type" "text/plain"
 995                                      "Content-length" (@ content length))
 996                     :success (lambda ()
 997                                (refresh-layer *user-point-layer*)
 998                                (reset-layers-and-controls))))))
 999
1000        (defun delete-point ()
1001          "Purge currently selected user point from database."
1002          (let ((user-point-id (chain *current-user-point* fid)))
1003            (setf content
1004                  (chain *json-parser*
1005                         (write user-point-id)))
1006            ((@ *open-layers *Request *POST*)
1007             (create :url "/phoros-lib/delete-point"
1008                     :data content
1009                     :headers (create "Content-type" "text/plain"
1010                                      "Content-length" (@ content length))
1011                     :success (lambda ()
1012                                (refresh-layer *user-point-layer*)
1013                                (reset-layers-and-controls))))))
1014
1015        (defun draw-active-point ()
1016          "Draw an Active Point, i.e. a point used in subsequent
1017          photogrammetric calculations."
1018          (chain this active-point-layer
1019                 (add-features
1020                  (new ((@ *open-layers *feature *vector)
1021                        (new ((@ *open-layers *geometry *point)
1022                              (getprop this 'photo-parameters 'm)
1023                              (getprop this 'photo-parameters 'n))))))))
1024
1025        (defun image-click-action (clicked-image)
1026          (lambda (event)
1027            "Do appropriate things when an image is clicked into."
1028            (let* ((lonlat
1029                    ((@ (@ clicked-image map) get-lon-lat-from-view-port-px)
1030                     (@ event xy)))
1031                   (photo-parameters
1032                    (getprop clicked-image 'photo-parameters))
1033                   pristine-image-p content request)
1034              (setf (@ photo-parameters m) (@ lonlat lon)
1035                    (@ photo-parameters n) (@ lonlat lat))
1036              (remove-layer (getprop clicked-image 'map) "Active Point")
1037              (remove-any-layers "Epipolar Line")
1038              (setf *pristine-images-p* (not (some-active-point-p)))
1039              (setf (@ clicked-image active-point-layer)
1040                    (new (chain *open-layers
1041                                *layer
1042                                (*vector "Active Point"
1043                                         (create display-in-layer-switcher
1044                                                 nil)))))
1045              ((@ clicked-image map add-layer)
1046               (@ clicked-image active-point-layer))
1047              ((getprop clicked-image 'draw-active-point))
1048              (if
1049               *pristine-images-p*
1050               (progn
1051                 (chain *user-points-select-control* (unselect-all))
1052                 (reset-controls)
1053                 (setf (value-with-id "point-numeric-description")
1054                       (increment-numeric-text
1055                        (value-with-id "point-numeric-description")))
1056                 (remove-any-layers "User Point") ;from images
1057                 (loop
1058                    for i across *images* do
1059                      (unless (== i clicked-image)
1060                        (setf
1061                         (@ i epipolar-layer)
1062                         (new (chain *open-layers
1063                                     *layer
1064                                     (*vector "Epipolar Line"
1065                                              (create display-in-layer-switcher nil))))
1066                         content (chain *json-parser*
1067                                        (write
1068                                         (append (array photo-parameters)
1069                                                 (@ i photo-parameters))))
1070                         (@ i epipolar-request-response)
1071                         ((@ *open-layers *Request *POST*)
1072                          (create :url "/phoros-lib/epipolar-line"
1073                                  :data content
1074                                  :headers (create "Content-type" "text/plain"
1075                                                   "Content-length"
1076                                                   (@ content length))
1077                                  :success (getprop i 'draw-epipolar-line)
1078                                  :scope i)))
1079                        ((@ i map add-layer) (@ i epipolar-layer)))))
1080               (progn
1081                 (remove-any-layers "Epipolar Line")
1082                 (remove-any-layers "Estimated Position")
1083                 (let* ((active-pointed-photo-parameters
1084                         (loop
1085                            for i across *images*
1086                            when (has-layer-p (getprop i 'map) "Active Point")
1087                            collect (getprop i 'photo-parameters)))
1088                        (content
1089                         (chain *json-parser*
1090                                (write
1091                                 (list active-pointed-photo-parameters
1092                                       (chain *images*
1093                                              (map #'(lambda (x)
1094                                                       (getprop
1095                                                        x 'photo-parameters)))))))))
1096                   (setf (@ clicked-image estimated-positions-request-response)
1097                         ((@ *open-layers *Request *POST*)
1098                          (create :url "/phoros-lib/estimated-positions"
1099                                  :data content
1100                                  :headers (create "Content-type" "text/plain"
1101                                                   "Content-length"
1102                                                   (@ content length))
1103                                  :success (getprop clicked-image
1104                                                    'draw-estimated-positions)
1105                                  :scope clicked-image)))))))))
1106
1107        (defun iso-time-string (lisp-time)
1108          "Return Lisp universal time formatted as ISO time string"
1109          (let* ((unix-time (- lisp-time +unix-epoch+))
1110                 (js-date (new (*date (* 1000 unix-time)))))
1111            (chain *open-layers *date (to-i-s-o-string js-date))))
1112
1113        (defun show-photo ()
1114          "Show the photo described in this object's photo-parameters."
1115          (loop
1116             repeat ((getprop this 'map 'get-num-layers))
1117             do ((getprop this 'map 'layers 0 'destroy)))
1118          ((getprop this 'map 'add-layer)
1119           (new (chain
1120                 *open-layers
1121                 *layer
1122                 (*image
1123                  "Photo"
1124                  (photo-path (getprop this 'photo-parameters))
1125                  (new ((@ *open-layers *bounds) -.5 -.5
1126                        (+ (getprop this 'photo-parameters 'sensor-width-pix)
1127                           .5)
1128                        (+ (getprop this 'photo-parameters 'sensor-height-pix)
1129                           .5)))         ; coordinates shown
1130                  (new ((@ *open-layers *size) 512 256))
1131                  (create)))))
1132          (chain this map (zoom-to-max-extent))
1133          (setf (chain this trigger-time-div inner-h-t-m-l)
1134                (iso-time-string (getprop this 'photo-parameters 'trigger-time))))
1135
1136        (defun zoom-images-to-max-extent ()
1137          "Zoom out all images."
1138          (loop for i across *images* do (chain i map (zoom-to-max-extent))))
1139
1140        (defun zoom-anything-to-point ()
1141          "For streetmap and for images that have an Active Point or an
1142 Estimated Position, zoom in and recenter."
1143          (when (checkbox-status-with-id "zoom-to-point-p")
1144            (let ((point-lonlat
1145                   (new (chain *open-layers
1146                               (*lon-lat (chain *global-position* longitude)
1147                                         (chain *global-position* latitude))
1148                               (transform +geographic+ +spherical-mercator+)))))
1149              (when point-lonlat
1150                (chain *streetmap*
1151                       (set-center point-lonlat 18 nil t))))
1152            (loop for i across *images* do
1153                 (let ((point-lonlat
1154                        (cond
1155                          ((has-layer-p (chain i map) "Active Point")
1156                           (new (chain *open-layers (*lon-lat
1157                                                     (chain i photo-parameters m)
1158                                                     (chain i photo-parameters n)))))
1159                          ((has-layer-p (chain i map) "Estimated Position")
1160                           (chain i estimated-position-lonlat))
1161                          (t false))))
1162                   (when point-lonlat
1163                     (chain i map (set-center point-lonlat 4 nil t)))))))
1164
1165        (defun initialize-image (image-index)
1166          "Create an image usable for displaying photos at position
1167 image-index in array *images*."
1168          (setf (aref *images* image-index) (new *image))
1169          (setf (@ (aref *images* image-index) trigger-time-div)
1170                (chain
1171                 document
1172                 (get-element-by-id (+ "image-" image-index "-trigger-time"))))
1173          (setf (@ (aref *images* image-index) image-click-action)
1174                (image-click-action (aref *images* image-index)))
1175          (setf (@ (aref *images* image-index) click)
1176                (new (*click-control*
1177                      (create :trigger (@ (aref *images* image-index)
1178                                          image-click-action)))))
1179          (chain (aref *images* image-index)
1180                 map
1181                 (add-control
1182                  (@ (aref *images* image-index) click)))
1183          (chain (aref *images* image-index) click (activate))
1184          ;;(chain (aref *images* image-index)
1185          ;;       map
1186          ;;       (add-control
1187          ;;        (new (chain *open-layers
1188          ;;                    *control
1189          ;;                    (*mouse-position
1190          ;;                     (create
1191          ;;                      div (chain
1192          ;;                           document
1193          ;;                           (get-element-by-id
1194          ;;                            (+ "image-" image-index "-zoom")))))))))
1195          (chain (aref *images* image-index)
1196                 map
1197                 (add-control
1198                  (new (chain *open-layers
1199                              *control
1200                              (*layer-switcher
1201                               (create
1202                                div (chain
1203                                     document
1204                                     (get-element-by-id
1205                                      (+ "image-" image-index "-layer-switcher")))
1206                                rounded-corner nil))))))
1207          (let ((pan-west-control
1208                 (new (chain *open-layers *control (*pan "West"))))
1209                (pan-north-control
1210                 (new (chain *open-layers *control (*pan "North"))))
1211                (pan-south-control
1212                 (new (chain *open-layers *control (*pan "South"))))
1213                (pan-east-control
1214                 (new (chain *open-layers *control (*pan "East"))))
1215                (zoom-in-control
1216                 (new (chain *open-layers *control (*zoom-in))))
1217                (zoom-out-control
1218                 (new (chain *open-layers *control (*zoom-out))))
1219                (zoom-to-max-extent-control
1220                 (new (chain *open-layers *control (*zoom-to-max-extent))))
1221                (pan-zoom-panel
1222                 (new (chain *open-layers
1223                             *control
1224                             (*panel
1225                              (create div
1226                                      (chain
1227                                       document
1228                                       (get-element-by-id
1229                                        (+ "image-" image-index "-zoom")))))))))
1230            (chain (aref *images* image-index) map (add-control pan-zoom-panel))
1231            (chain pan-zoom-panel (add-controls (array pan-west-control
1232                                                       pan-north-control
1233                                                       pan-south-control
1234                                                       pan-east-control
1235                                                       zoom-in-control
1236                                                       zoom-out-control
1237                                                       zoom-to-max-extent-control))))
1238          (chain (aref *images* image-index)
1239                 map
1240                 (render (chain document
1241                                (get-element-by-id
1242                                 (+ "image-" image-index))))))
1243
1244        (defun user-point-selected (event)
1245          "Things to do once a user point is selected."
1246          (remove-any-layers "Active Point")
1247          (remove-any-layers "Epipolar Line")
1248          (remove-any-layers "Estimated Position")
1249          (user-point-selection-changed event))
1250
1251        (defun user-point-unselected (event)
1252          "Things to do once a user point is selected."
1253          (user-point-selection-changed event))
1254
1255        (defun user-point-selection-changed (event)
1256          "Things to do once a user point is selected or unselected."
1257          (hide-aux-data-choice)
1258          ;; after single select: same as event
1259          (setf *current-user-point* (chain event object selected-features 0))
1260          (let ((selected-features-count
1261                 (chain *user-point-layer* selected-features length)))
1262            (setf (chain *user-point-layer* style-map)
1263                  (user-point-style-map
1264                   (when (> selected-features-count 1)
1265                     "${numericDescription}")))
1266            (if (> selected-features-count 1)
1267                (progn
1268                  (hide-element-with-id "real-phoros-controls")
1269                  (reveal-element-with-id "multiple-points-phoros-controls"))
1270                (progn
1271                  (hide-element-with-id "multiple-points-phoros-controls")
1272                  (reveal-element-with-id "real-phoros-controls"))))
1273          (chain *user-point-layer* (redraw))
1274          (remove-any-layers "User Point") ;from images
1275          (if (write-permission-p (chain event feature attributes user-name))
1276              (progn
1277                (setf (chain document
1278                             (get-element-by-id "finish-point-button")
1279                             onclick)
1280                      update-point)
1281                (enable-element-with-id "finish-point-button")
1282                (enable-element-with-id "delete-point-button")
1283                (setf (inner-html-with-id "h2-controls") "Edit Point"))
1284              (progn
1285                (disable-element-with-id "finish-point-button")
1286                (disable-element-with-id "delete-point-button")
1287                (setf (inner-html-with-id "h2-controls") "View Point")))
1288          (setf (inner-html-with-id "creator")
1289                (+ "(by " (chain event feature attributes user-name) ")"))
1290          (setf (value-with-id "point-attribute")
1291                (chain event feature attributes attribute))
1292          (setf (value-with-id "point-description")
1293                (chain event feature attributes description))
1294          (setf (value-with-id "point-numeric-description")
1295                (chain event feature attributes numeric-description))
1296          (setf (inner-html-with-id "point-creation-date")
1297                (chain event feature attributes creation-date))
1298          (setf (inner-html-with-id "aux-numeric-list")
1299                (html-ordered-list
1300                 (chain event feature attributes aux-numeric)))
1301          (setf (inner-html-with-id "aux-text-list")
1302                (html-ordered-list
1303                 (chain event feature attributes aux-text)))
1304          (setf content
1305                (chain *json-parser*
1306                       (write
1307                        (array (chain event
1308                                      object
1309                                      selected-features
1310                                      (map (lambda (x) (@ x fid))))
1311                               (loop
1312                                  for i across *images*
1313                                  collect (chain i photo-parameters))))))
1314          (setf *user-point-in-images-response*
1315                ((@ *open-layers *Request *POST*)
1316                 (create :url "/phoros-lib/user-point-positions"
1317                         :data content
1318                         :headers (create "Content-type" "text/plain"
1319                                          "Content-length" (@ content length))
1320                         :success draw-user-point))))
1321
1322        (defun aux-point-distance-selected ()
1323          "Things to do on change of aux-point-distance select element."
1324          (chain *nearest-aux-points-select-control*
1325                 (unselect-all))
1326          (chain *nearest-aux-points-select-control*
1327                 (select
1328                  (chain
1329                   (elt (chain *streetmap-nearest-aux-points-layer* features)
1330                        (chain *aux-point-distance-select*
1331                               options
1332                               selected-index))))))
1333
1334        (defun enable-aux-point-selection ()
1335          "Check checkbox include-aux-data-p and act accordingly."
1336          (setf (checkbox-status-with-id "include-aux-data-p") t)
1337          (flip-aux-data-inclusion))
1338
1339        (defun flip-aux-data-inclusion ()
1340          "Query status of checkbox include-aux-data-p and act
1341 accordingly."
1342          (if (checkbox-status-with-id "include-aux-data-p")
1343              (chain *streetmap-nearest-aux-points-layer*
1344                     (set-visibility t))
1345              (chain *streetmap-nearest-aux-points-layer*
1346                     (set-visibility nil))))
1347
1348        (defun html-ordered-list (aux-data)
1349          "Return a html-formatted list from aux-data."
1350          (if aux-data
1351              (who-ps-html
1352               (:ol :class "aux-data-list"
1353                    (chain aux-data
1354                           (reduce (lambda (x y)
1355                                     (+ x (who-ps-html (:li y))))
1356                                   ""))))
1357              ""))
1358
1359        (defun nearest-aux-point-selected (event)
1360          "Things to do once a nearest auxiliary point is selected in streetmap."
1361          (setf *current-nearest-aux-point* (chain event feature))
1362          (let ((aux-numeric
1363                 (chain event feature attributes aux-numeric))
1364                (aux-text
1365                 (chain event feature attributes aux-text))
1366                (distance
1367                 (chain event feature attributes distance)))
1368            (setf (chain *aux-point-distance-select* options selected-index)
1369                  (chain event feature fid))
1370            (setf (inner-html-with-id "aux-numeric-list")
1371                  (html-ordered-list aux-numeric))
1372            (setf (inner-html-with-id "aux-text-list")
1373                  (html-ordered-list aux-text))))
1374
1375        (defun init ()
1376          "Prepare user's playground."
1377          (when (write-permission-p)
1378            (enable-element-with-id "point-attribute")
1379            (enable-element-with-id "point-description")
1380            (enable-element-with-id "point-numeric-description")
1381            (hide-element-with-id "multiple-points-phoros-controls")
1382            (setf (inner-html-with-id "h2-controls") "Create Point"))
1383          (setf *point-attributes-select*
1384                (chain document (get-element-by-id "point-attribute")))
1385          (setf *aux-point-distance-select*
1386                (chain document (get-element-by-id "aux-point-distance")))
1387          (loop for i in '("solitary" "polyline" "polygon") do
1388               (setf point-attribute-item (chain document (create-element "option")))
1389               (setf (chain point-attribute-item text) i)
1390               (chain *point-attributes-select* (add point-attribute-item null))) ;TODO: input of user-defined attributes
1391          (hide-aux-data-choice)
1392          (setf *streetmap*
1393                (new (chain
1394                      *open-layers
1395                      (*map "streetmap"
1396                            (create projection +geographic+
1397                                    display-projection +geographic+
1398                                    controls (array (new (chain *open-layers
1399                                                                *control
1400                                                                (*navigation)))
1401                                                    (new (chain *open-layers
1402                                                                *control
1403                                                                (*attribution)))))))))
1404          (chain *streetmap*
1405                 (add-control
1406                  (new (chain *open-layers
1407                              *control
1408                              (*layer-switcher
1409                               (create
1410                                div (chain
1411                                     document
1412                                     (get-element-by-id
1413                                      "streetmap-layer-switcher"))
1414                                rounded-corner nil))))))
1415          (let ((pan-west-control
1416                 (new (chain *open-layers *control (*pan "West"))))
1417                (pan-north-control
1418                 (new (chain *open-layers *control (*pan "North"))))
1419                (pan-south-control
1420                 (new (chain *open-layers *control (*pan "South"))))
1421                (pan-east-control
1422                 (new (chain *open-layers *control (*pan "East"))))
1423                (zoom-in-control
1424                 (new (chain *open-layers *control (*zoom-in))))
1425                (zoom-out-control
1426                 (new (chain *open-layers *control (*zoom-out))))
1427                (zoom-to-max-extent-control
1428                 (new (chain
1429                       *open-layers
1430                       *control
1431                       (*button
1432                        (create
1433                         display-class "streetmapZoomToMaxExtent"
1434                         trigger (lambda ()
1435                                   (chain *streetmap*
1436                                          (zoom-to-extent
1437                                           +presentation-project-bounds+ ))))))))
1438                (pan-zoom-panel
1439                 (new (chain *open-layers
1440                             *control
1441                             (*panel
1442                              (create div
1443                                      (chain
1444                                       document
1445                                       (get-element-by-id
1446                                        "streetmap-zoom")))))))
1447                (overview-map
1448                 (new (chain *open-layers
1449                             *control
1450                             (*overview-map
1451                              (create
1452                               min-ratio 14
1453                               max-ratio 16
1454                               div (chain document
1455                                          (get-element-by-id
1456                                           "streetmap-overview")))))))
1457                (mouse-position-control
1458                 (new (chain *open-layers
1459                             *control
1460                             (*mouse-position
1461                              (create div (chain document
1462                                                 (get-element-by-id
1463                                                  "streetmap-mouse-position"))
1464                                      empty-string "longitude, latitude")))))
1465                (scale-line-control
1466                 (new (chain *open-layers
1467                             *control
1468                             *scale-line))))
1469            (chain *streetmap*
1470                   (add-control pan-zoom-panel))
1471            (chain pan-zoom-panel
1472                   (add-controls (array pan-west-control
1473                                        pan-north-control
1474                                        pan-south-control
1475                                        pan-east-control
1476                                        zoom-in-control
1477                                        zoom-out-control
1478                                        zoom-to-max-extent-control)))
1479            (chain *streetmap*
1480                   (add-control *click-streetmap*))
1481            (chain *click-streetmap* (activate))
1482
1483            (chain *user-point-layer*
1484                   events
1485                   (register "featureselected"
1486                             *user-point-layer*
1487                             user-point-selected))
1488            (chain *user-point-layer*
1489                   events
1490                   (register "featureunselected"
1491                             *user-point-layer*
1492                             user-point-unselected))
1493            (chain *streetmap-nearest-aux-points-layer*
1494                   events
1495                   (register "featureselected"
1496                             *streetmap-nearest-aux-points-layer*
1497                             nearest-aux-point-selected))
1498            (chain *streetmap* (add-control *nearest-aux-points-hover-control*))
1499            (chain *streetmap* (add-control *nearest-aux-points-select-control*))
1500            (chain *streetmap* (add-control *user-points-hover-control*))
1501            (chain *streetmap* (add-control *user-points-select-control*))
1502            (chain *user-points-hover-control* (activate))
1503            (chain *user-points-select-control* (activate))
1504            (chain *nearest-aux-points-hover-control* (activate))
1505            (chain *nearest-aux-points-select-control* (activate))
1506
1507            (chain *streetmap* (add-layer *osm-layer*))
1508            (try (chain *streetmap* (add-layer *google-streetmap-layer*))
1509                 (:catch (c)
1510                   (chain *streetmap* (remove-layer *google-streetmap-layer*))))
1511            (chain *streetmap* (add-layer *streetmap-nearest-aux-points-layer*))
1512            (chain *streetmap* (add-layer *survey-layer*))
1513            (chain *streetmap* (add-layer *aux-point-layer*))
1514            (chain *streetmap* (add-layer *user-point-layer*))
1515            (setf (chain overview-map element)
1516                  (chain document (get-element-by-id
1517                                   "streetmap-overview-element")))
1518            (chain *streetmap* (add-control overview-map))
1519            (chain *streetmap*
1520                   (zoom-to-extent +presentation-project-bounds+))
1521            (chain *streetmap* (add-control mouse-position-control))
1522            (chain *streetmap* (add-control scale-line-control)))
1523          (loop
1524             for i from 0 to (lisp (1- *number-of-images*))
1525             do (initialize-image i))
1526          (add-help-events))))))