db-tables.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011, 2017 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
  19 (in-package :phoros)
  20
  21 (defun nuke-all-tables ()
  22   "Drop all tables (except PostGIS helper tables) and sequences in current database.  TODO: also drop our functions and types."
  23   (let ((user-tables (list-tables))
  24         (sequences (list-sequences))
  25         (views (list-views))
  26           (system-tables '(:spatial-ref-sys :geometry-columns)))
  27     (dolist (system-table system-tables)
  28       (setf user-tables (remove system-table user-tables)))
  29     (dolist (user-table user-tables)
  30       (execute (format nil "DROP TABLE IF EXISTS ~A CASCADE" (s-sql:to-sql-name user-table))))
  31     (dolist (sequence sequences)
  32       (execute (format nil "DROP SEQUENCE IF EXISTS ~A CASCADE" (s-sql:to-sql-name sequence))))
  33     (dolist (view views)
  34       (execute (format nil "DROP VIEW IF EXISTS ~A CASCADE" (s-sql:to-sql-name view))))))
  35
  36 ;;; Used only to add Spherical Mercator in case it's missing
  37 (defclass spatial-ref-sys ()
  38   ((srid
  39     :col-type integer
  40     :initarg :srid)
  41    (auth-name
  42     :col-type (or db-null (varchar 256))
  43     :initarg :auth-name)
  44    (auth-srid
  45     :col-type (or db-null integer)
  46     :initarg :auth-srid)
  47    (srtext
  48     :col-type (or db-null (varchar 2048))
  49     :initarg :srtext)
  50    (proj4text
  51     :col-type (or db-null (varchar 2048))
  52     :initarg :proj4text))
  53   (:metaclass dao-class)
  54   (:keys srid)
  55   (:documentation "PostGIS system table as defined in http://postgis.refractions.net/documentation/manual-1.3/ch04.html#id2571306"))
  56
  57 ;;TODO: make a spatial-ref-sys table
  58
  59 (defun add-spherical-mercator-ref ()
  60   "Tell PostGIS about Spherical Mercator if necessary."
  61   (let ((spherical-mercator
  62          (make-instance
  63           'spatial-ref-sys
  64           :srid 900913
  65           :auth-name "spatialreferencing.org"
  66           :auth-srid 900913
  67           :srtext "PROJCS[\"Popular Visualisation CRS / Mercator (deprecated)\",GEOGCS[\"Popular Visualisation CRS\",DATUM[\"Popular_Visualisation_Datum\",SPHEROID[\"Popular Visualisation Sphere\",6378137,0,AUTHORITY[\"EPSG\",\"7059\"]],TOWGS84[0,0,0,0,0,0,0],AUTHORITY[\"EPSG\",\"6055\"]],PRIMEM[\"Greenwich\",0,AUTHORITY[\"EPSG\",\"8901\"]],UNIT[\"degree\",0.01745329251994328,AUTHORITY[\"EPSG\",\"9122\"]],AUTHORITY[\"EPSG\",\"4055\"]],UNIT[\"metre\",1,AUTHORITY[\"EPSG\",\"9001\"]],PROJECTION[\"Mercator_1SP\"],PARAMETER[\"central_meridian\",0],PARAMETER[\"scale_factor\",1],PARAMETER[\"false_easting\",0],PARAMETER[\"false_northing\",0],AUTHORITY[\"EPSG\",\"3785\"],AXIS[\"X\",EAST],AXIS[\"Y\",NORTH]]"
  68           :proj4text "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +units=m +k=1.0 +nadgrids=@null +no_defs")))
  69     (unless (dao-exists-p spherical-mercator)
  70       (insert-dao spherical-mercator))))
  71
  72 ;;TODO: make a geometry-columns table
  73 ;;
  74 ;;CREATE TABLE geometry_columns (
  75 ;;  f_table_catalog    VARRCHAR(256) NOT NULL,
  76 ;;  f_table_schema     VARCHAR(256) NOT NULL,
  77 ;;  f_table_nam        VARCHAR(256) NOT NULL,
  78 ;;  f_geometry_column  VARCHAR(256) NOT NULL,
  79 ;;  coord_dimension    INTEGER NOT NULL,
  80 ;;  srid               INTEGER NOT NULL,
  81 ;;  type               VARCHAR(30) NOT NULL
  82 ;;)
  83
  84 (defclass sys-user ()
  85   ((user-id
  86     :reader user-id
  87
  88     :col-type integer
  89     :col-default (:nextval 'sys-user-id-seq))
  90    (user-name
  91     :col-type text
  92     :initarg :user-name
  93     :documentation "This one is used for authentication.")
  94    (user-password
  95     :writer (setf user-password)
  96     :col-type text
  97     :initarg :user-password)
  98    (user-full-name
  99     :writer (setf user-full-name)
 100     :col-type text
 101     :initarg :user-full-name))
 102   (:metaclass dao-class)
 103   (:keys user-id)
 104   (:documentation "List of users of the presentation front end.  This is certainly not a full-fledged authentication system."))
 105
 106 (deftable sys-user
 107   (:create-sequence 'sys-user-id-seq)
 108   (!dao-def))
 109
 110 (defclass sys-acquisition-project ()
 111   ((acquisition-project-id
 112     :reader acquisition-project-id
 113     :col-type integer
 114     :col-default (:nextval 'sys-acquisition-project-id-seq))
 115    (common-table-name
 116     :col-type text
 117     :initarg :common-table-name
 118     :documentation "Name of this project's data tables sans their canonical prefixes and suffixes.  Serves as a human-readable acquisition procect identifier.  Should be one table for all projects but this seems to come with a speed penalty."))
 119   (:metaclass dao-class)
 120   (:keys acquisition-project-id)
 121   (:documentation "An acquisition project is basically a set of measurements that is stored in a common table."))
 122
 123 (deftable sys-acquisition-project
 124   (:create-sequence 'sys-acquisition-project-id-seq)
 125   (!dao-def)
 126   (:alter-table sys-acquisition-project
 127                 :add :constraint "common-table-name-unique"
 128                 :unique 'common-table-name))
 129
 130 (defclass sys-presentation-project ()
 131   ((presentation-project-id
 132     :reader presentation-project-id
 133     :col-type integer
 134     :col-default (:nextval 'sys-presentation-project-id-seq))
 135    (presentation-project-name
 136     :col-type text
 137     :initarg :presentation-project-name)
 138    (bounding-box
 139     :col-type (or db-null text)
 140     :accessor bounding-box
 141     :documentation "Extent of this presentation project."))
 142   (:metaclass dao-class)
 143   (:keys presentation-project-name))
 144
 145 (deftable sys-presentation-project
 146   (:create-sequence 'sys-presentation-project-id-seq)
 147   (!dao-def)
 148   (:alter-table sys-presentation-project
 149                 :add :constraint "presentation-project-id-unique"
 150                 :unique 'presentation-project-id))
 151
 152 (defclass sys-selectable-restriction ()
 153   ((restriction-id
 154     :col-type text
 155     :initarg :restriction-id
 156     :documentation "Short descriptive string; to be used for selection of restriction on client.")
 157    (presentation-project-id
 158     :col-type integer
 159     :initarg :presentation-project-id
 160     :documentation "Presentation Project that is allowed to use the sql-clause.")
 161    (sql-clause
 162     :col-type text
 163     :initarg :sql-clause
 164     :reader sql-clause
 165     :documentation "SQL clause suitable as an AND clause in aggregate view."))
 166   (:metaclass dao-class)
 167   (:keys presentation-project-id restriction-id)
 168   (:documentation "User-selectable SQL AND clauses usable in the WHERE clause of aggregate view."))
 169
 170 (deftable sys-selectable-restriction
 171   (!dao-def)
 172   (!foreign 'sys-presentation-project 'presentation-project-id :on-delete :cascade :on-update :cascade))
 173
 174 (defclass sys-user-role ()
 175   ((user-id
 176     :initarg :user-id
 177     :col-type integer)
 178    (presentation-project-id
 179     :initarg :presentation-project-id
 180     :col-type integer)
 181    (user-role
 182     :initarg :user-role
 183     :col-type text
 184     :documentation "One of read, write, admin.")
 185    (bounding-box
 186     :col-type (or db-null text)
 187     :accessor bounding-box
 188     :documentation "Streetmap zoom extent last time user left Phoros.")
 189    (cursor
 190     :col-type (or db-null geometry)
 191     :accessor cursor
 192     :documentation "Point; user's work coordinate in streetmap last time they left Phoros."))
 193   (:metaclass dao-class)
 194   (:keys user-id presentation-project-id))
 195
 196 (deftable sys-user-role
 197   (!dao-def)
 198   (!foreign 'sys-user 'user-id :on-delete :cascade :on-update :cascade)
 199   (!foreign 'sys-presentation-project 'presentation-project-id
 200             :on-delete :cascade :on-update :cascade))
 201
 202 (defclass sys-measurement ()
 203   ((measurement-id
 204     :reader measurement-id
 205     :col-type integer
 206     :col-default (:nextval 'sys-measurement-id-seq))
 207    (acquisition-project-id
 208     :initarg :acquisition-project-id
 209     :col-type integer)
 210    (directory
 211     :initarg :directory
 212     :col-type text
 213     :documentation
 214     "Below some universal root common to all measurements; excluding
 215 `applanix/´ `images/´ etc.
 216
 217 The entire directory structure looks like this:
 218
 219 Points
 220 ======
 221 /some/path/in/our/system/this/measurement/blah/applanix/points/xyz-event1.txt
 222 /some/path/in/our/system/this/measurement/blah/applanix/points/uvw-event2.txt
 223                                           ---- +++++++++++++++ ----+++++ ++++
 224 ^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^                               ^
 225     universal root       stored here in                                event
 226                          slot directory                                number
 227
 228 Images
 229 ======
 230 /some/path/in/our/system/this/measurement/blah/images/front77.pictures
 231 /some/path/in/our/system/this/measurement/blah/images/front78.pictures
 232                                           ---- ++++++         ++++++++
 233 ^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^             ^^^^^^^^^^^^^^^^
 234     universal root       stored here in               stored file name
 235                          slot directory
 236
 237 ++++ means constant
 238 ---- means unimportant
 239
 240 TODO: /images/ part not currently enforced.")
 241    (cartesian-system
 242     :initarg :cartesian-system
 243     :col-type text
 244     :documentation
 245     "Definition (as a Proj.4 string) of the coordinate system the recorded standard deviations are in."))
 246   (:metaclass dao-class)
 247   (:keys measurement-id)
 248   (:documentation "A measurement comprises .pictures files and one set of GPS event log files in a dedicated directory."))
 249
 250 (deftable sys-measurement
 251   (:create-sequence 'sys-measurement-id-seq)
 252   (!dao-def)
 253   (!index 'measurement-id)
 254   (!foreign 'sys-acquisition-project 'acquisition-project-id
 255             :on-delete :cascade :on-update :cascade))
 256
 257 (defclass sys-presentation ()
 258   ((presentation-project-id
 259     :initarg :presentation-project-id
 260     :col-type integer)
 261    (measurement-id
 262     :initarg :measurement-id
 263     :col-type integer))
 264   (:metaclass dao-class)
 265   (:keys presentation-project-id measurement-id)
 266   (:documentation "Tell us which measurements belong to which presentation project(s)."))
 267
 268 (deftable sys-presentation
 269   (!dao-def)
 270   (!index 'measurement-id)
 271   (!foreign 'sys-presentation-project 'presentation-project-id
 272             :on-delete :cascade :on-update :cascade)
 273   (!foreign 'sys-measurement 'measurement-id
 274             :on-delete :cascade :on-update :cascade))
 275
 276 (defclass sys-camera-hardware ()
 277   ((camera-hardware-id
 278     :reader camera-hardware-id
 279     :col-type integer
 280     :col-default (:nextval 'sys-camera-hardware-id-seq))
 281    (sensor-width-pix
 282     :col-type integer)
 283    (sensor-height-pix
 284     :col-type integer)
 285    (pix-size
 286     :col-type double-float)
 287    (channels
 288     :col-type integer)
 289    (pix-depth
 290     :col-type integer)
 291    (color-raiser
 292     :col-type float[]
 293     :documentation "Array of multipliers for red, green, blue.")
 294    (bayer-pattern
 295     :col-type integer[]
 296     :documentation "Array containing the colors of the first pixels of the first rows (actually, row, as postmodern can't handle two-dimensional arrays (and if it could, we wouldn't use them anyway)).  Each pixel is to be interpreted as a three-byte RGB value, red in the least-significant byte.")
 297    (serial-number
 298     :col-type text)
 299    (description
 300     :col-type text
 301     :description "Camera type, manufacturer, etc."))
 302   (:metaclass dao-class)
 303   (:keys camera-hardware-id))
 304
 305 (deftable sys-camera-hardware
 306   (:create-sequence 'sys-camera-hardware-id-seq)
 307   (!dao-def)
 308   (!index 'camera-hardware-id))
 309
 310 (defclass sys-lens ()
 311   ((lens-id
 312     :reader lens-id
 313     :col-type integer
 314     :col-default (:nextval 'sys-lens-id-seq))
 315    (c
 316     :col-type double-float
 317     :documentation "Focal length.  Only for human consumption.")
 318    (serial-number
 319     :col-type text)
 320    (description
 321     :col-type text
 322     :documentation "Lens type, manufacturer, etc."))
 323   (:metaclass dao-class)
 324   (:keys lens-id))
 325
 326 (deftable sys-lens
 327   (:create-sequence 'sys-lens-id-seq)
 328   (!dao-def))
 329
 330 (defclass sys-generic-device ()
 331   ((generic-device-id
 332     :reader generic-device-id
 333     :col-type integer
 334     :col-default (:nextval 'sys-generic-device-id-seq))
 335    (camera-hardware-id
 336     :initarg :camera-hardware-id
 337     :col-type (or db-null integer))
 338    (lens-id
 339     :initarg :lens-id
 340     :col-type (or db-null integer))
 341    (scanner-id
 342     :initarg :scanner-id
 343     :col-type (or db-null integer)
 344     :documentation "Scanners yet to be defined."))
 345   (:metaclass dao-class)
 346   (:keys generic-device-id)
 347   (:documentation "A row should describe either a camera with a lens, or a laser scanner."))
 348
 349 (deftable sys-generic-device
 350   (:create-sequence 'sys-generic-device-id-seq)
 351   (!dao-def)
 352   (!index 'generic-device-id)
 353   (!index 'camera-hardware-id)
 354   (!foreign 'sys-camera-hardware 'camera-hardware-id
 355             :on-delete :restrict :on-update :restrict)
 356   (!foreign 'sys-lens 'lens-id :on-delete :restrict :on-update :restrict)
 357   ;;;; Once we have a sys-scanner table:
 358   ;;(!foreign 'sys-scanner 'scanner-id :on-delete :restrict :on-update :restrict)
 359   )
 360
 361 (defclass sys-device-stage-of-life ()
 362   ((device-stage-of-life-id
 363     :reader device-stage-of-life-id
 364     :col-type integer
 365     :col-default (:nextval 'sys-device-stage-of-life-seq))
 366    (recorded-device-id
 367     :col-type text
 368     :documentation "Must be stored next to each data record.  Example: in a .pictures file, this is the value of `cam=´.")
 369    (event-number
 370     :reader event-number
 371     :col-type text
 372     :documentation "Identifier for the GPS event that triggers this device.  Must correspond to the N the GPS file name: ...eventN.txt.")
 373    (generic-device-id
 374     :col-type integer)
 375    (vehicle-name
 376     :col-type text)
 377    (casing-name
 378     :col-type text
 379     :documentation "Something like `upper rear left´ or maybe `1.2.1´")
 380    (computer-name
 381     :col-type text
 382     :documentation "Computer (or or other recording device) this device is connected to.")
 383    (computer-interface-name
 384     :col-type text
 385     :documentation "Things like `eth0´, `COM1´ etc.")
 386    (mounting-date
 387     :col-type :timestamp-with-time-zone)
 388    (unmounting-date
 389     :col-type (or db-null :timestamp-with-time-zone)
 390     :documentation "Date and time when this device was unmounted or altered in other ways that may render the current calibration invalid."))
 391   (:metaclass dao-class)
 392   (:keys device-stage-of-life-id)
 393   (:documentation "This data is to be collected on the measuring vehicle.  There must be a new record for every relevant change (including accidental ones) in device configuration."))
 394
 395 (deftable sys-device-stage-of-life
 396   (:create-sequence 'sys-device-stage-of-life-seq)
 397   (!dao-def)
 398   (!index 'device-stage-of-life-id)
 399   (!index 'recorded-device-id)
 400   (!index 'mounting-date)
 401   (!index 'unmounting-date)
 402   (!foreign 'sys-generic-device 'generic-device-id
 403             :on-delete :restrict :on-update :restrict))
 404
 405 (defclass sys-camera-calibration ()
 406   ((device-stage-of-life-id
 407     :reader device-stage-of-life-id
 408     :col-type integer
 409     :documentation "This tells us what hardware this calibration is for.")
 410    (date
 411     :reader date
 412     :col-type :timestamp-with-time-zone)
 413    (person
 414     :col-type text)
 415    (main-description
 416     :col-type text
 417     :documentation "Regarding this entire set of calibration data.  Note the special-purpose description fields inner-orientation-description, outer-orientation-description, boresight-description.")
 418    (usable
 419     :col-type boolean
 420     :documentation "If false: just display images, don't perform photogrammetric calculations.")
 421    (debug
 422     :col-type boolean
 423     :documentation "If true: not for production use; may be altered or deleted at any time.")
 424    (photogrammetry-version
 425     :col-type text
 426     :documentation "Software version used to create this data.")
 427    (mounting-angle
 428     :col-type integer
 429     :documentation "Head up = 0; right ear up = 90; left ear up = -90; head down = 180.")
 430    (inner-orientation-description
 431     :col-type text
 432     :documentation "Comments regarding inner orientation calibration.")
 433    (c
 434     :col-type double-float
 435     :documentation "Inner orientation: focal length.")
 436    (xh
 437     :col-type double-float
 438     :documentation "Inner orientation: principal point displacement.")
 439    (yh
 440     :col-type double-float
 441     :documentation "Inner orientation: principal point displacement.")
 442    (a1
 443     :col-type double-float
 444     :documentation "Inner orientation: radial distortion.")
 445    (a2
 446     :col-type double-float
 447     :documentation "Inner orientation: radial distortion.")
 448    (a3
 449     :col-type double-float
 450     :documentation "Inner orientation: radial distortion.")
 451    (b1
 452     :col-type double-float
 453     :documentation "Inner orientation: asymmetric and tangential distortion.")
 454    (b2
 455     :col-type double-float
 456     :documentation "Inner orientation: asymmetric and tangential distortion.")
 457    (c1
 458     :col-type double-float
 459     :documentation "Inner orientation: affinity and shear distortion.")
 460    (c2
 461     :col-type double-float
 462     :documentation "Inner orientation: affinity and shear distortion.")
 463    (r0
 464     :col-type double-float
 465     :documentation "Inner orientation.")
 466    (outer-orientation-description
 467     :col-type text
 468     :documentation "Comments regarding outer orientation calibration.")
 469    (dx
 470     :col-type double-float
 471     :documentation "Outer orientation; in metres.")
 472    (dy
 473     :col-type double-float
 474     :documentation "Outer orientation; in metres.")
 475    (dz
 476     :col-type double-float
 477     :documentation "Outer orientation; in metres.")
 478    (omega
 479     :col-type double-float
 480     :documentation "Outer orientation.")
 481    (phi
 482     :col-type double-float
 483     :documentation "Outer orientation.")
 484    (kappa
 485     :col-type double-float
 486     :documentation "Outer orientation.")
 487    (boresight-description
 488     :col-type text
 489     :documentation "Comments regarding boresight alignment calibration.")
 490    (b-dx
 491     :col-type double-float
 492     :documentation "Boresight alignment.")
 493    (b-dy
 494     :col-type double-float
 495     :documentation "Boresight alignment.")
 496    (b-dz
 497     :col-type double-float
 498     :documentation "Boresight alignment.")
 499    (b-ddx
 500     :col-type double-float
 501     :documentation "Boresight alignment.")
 502    (b-ddy
 503     :col-type double-float
 504     :Documentation "Boresight alignment.")
 505    (b-ddz
 506     :col-type double-float
 507     :documentation "Boresight alignment.")
 508    (b-rotx
 509     :col-type double-float
 510     :documentation "Boresight alignment.")
 511    (b-roty
 512     :col-type double-float
 513     :documentation "Boresight alignment.")
 514    (b-rotz
 515     :col-type double-float
 516     :documentation "Boresight alignment.")
 517    (b-drotx
 518     :col-type double-float
 519     :documentation "Boresight alignment.")
 520    (b-droty
 521     :col-type double-float
 522     :documentation "Boresight alignment.")
 523    (b-drotz
 524     :col-type double-float
 525     :documentation "Boresight alignment.")
 526    (nx
 527     :col-type double-float
 528     :documentation "Component of unit vector of vehicle ground plane.")
 529    (ny
 530     :col-type double-float
 531     :documentation "Component of unit vector of vehicle ground plane.")
 532    (nz
 533     :col-type double-float
 534     :documentation "Component of unit vector of vehicle ground plane.")
 535    (d
 536     :col-type double-float
 537     :documentation "Distance of vehicle ground plane."))
 538   (:metaclass dao-class)
 539   (:keys device-stage-of-life-id date)
 540   (:documentation "Camera calibration parameters."))
 541
 542 (deftable sys-camera-calibration
 543   (!dao-def)
 544   (!index 'device-stage-of-life-id)
 545   (!index 'date)
 546   (!foreign 'sys-device-stage-of-life 'device-stage-of-life-id
 547             :on-delete :restrict :on-update :restrict))
 548
 549 (defun phoros-db-major-version ()
 550   "Get the version number of the database structure we are currently
 551 connected to.  It is supposed to be equal to the :major part of
 552 phoros-version."
 553   (query
 554    (:select 'last-value :from 'sys-phoros-major-version)
 555    :single!))
 556
 557 (defun (setf phoros-db-major-version) (major-version)
 558   "Set the version number of the database structure we are currently
 559 connected to. This can only be done once per database."
 560   (execute
 561    (:create-sequence 'sys-phoros-major-version
 562                      :min-value -1
 563                      :max-value major-version
 564                      :start major-version))
 565   (phoros-db-major-version))
 566
 567 (defun assert-phoros-db-major-version ()
 568   "Check if phoros version and version of the database we are
 569 connected to match."
 570   (assert (= (phoros-db-major-version) (phoros-version :major t)) ()
 571           "Can't use a Phoros database structure of version ~D.  ~
 572            It should be version ~D.  ~
 573            Either create a new database structure using this version of ~
 574            Phoros, or use Phoros version ~2:*~D.x.x."
 575           (phoros-db-major-version) (phoros-version :major t)))
 576
 577 (defun assert-presentation-project (presentation-project-name)
 578   "Signal error if presentation-project-name can't be found in current
 579 database."
 580   (presentation-project-id-from-name presentation-project-name))
 581
 582 (defun presentation-project-id-from-name (presentation-project-name)
 583   "Get from current database the presentation-project-id associated
 584 with presentation-project-name.  Signal error if there isn't any."
 585   (let ((presentation-project
 586          (get-dao 'sys-presentation-project presentation-project-name)))
 587     (assert presentation-project ()
 588             "There is no presentation project called ~A."
 589             presentation-project-name)
 590     (presentation-project-id presentation-project)))
 591
 592 (defun assert-acquisition-project (acquisition-project-name)
 593   "Signal error if acquisition-project-name can't be found in current
 594 database."
 595   (assert (select-dao 'sys-acquisition-project
 596                       (:= 'common-table-name acquisition-project-name))
 597           ()
 598           "There is no acquisition project called ~A."
 599           acquisition-project-name))
 600
 601 (defun create-sys-tables ()
 602   "Create in current database a set of sys-* tables, i.e. tables that
 603 are used by all projects.  The database should probably be empty."
 604   (setf (phoros-db-major-version) (phoros-version :major t))
 605   (create-table 'sys-user)
 606   (create-table 'sys-acquisition-project)
 607   (create-table 'sys-presentation-project)
 608   (create-table 'sys-selectable-restriction)
 609   (create-table 'sys-user-role)
 610   (create-table 'sys-measurement)
 611   (create-table 'sys-presentation)
 612   (create-table 'sys-camera-hardware)
 613   (create-table 'sys-lens)
 614   (create-table 'sys-generic-device)
 615   (create-table 'sys-device-stage-of-life)
 616   (create-table 'sys-camera-calibration)
 617   (create-plpgsql-helpers))
 618
 619 (defun create-plpgsql-helpers ()
 620   "Create in current database a few SQL types and functions."
 621   (execute
 622    (format nil "
 623 CREATE OR REPLACE
 624 FUNCTION bendedness
 625          (point1 GEOMETRY, point2 GEOMETRY, point3 GEOMETRY)
 626 RETURNS DOUBLE PRECISION AS $$
 627 -- Phoros version ~A
 628 BEGIN
 629   RETURN abs(st_azimuth(point2, point3) - st_azimuth(point1, point2));
 630 END;
 631 $$ LANGUAGE plpgsql;"
 632            (phoros-version)))
 633   (execute
 634    "DROP TYPE IF EXISTS point_bag;")
 635   (execute
 636    "CREATE TYPE point_bag AS (id int, coordinates GEOMETRY);"))
 637
 638 (defun !!index (table field &key (index-type :btree))
 639   (format nil "CREATE INDEX ~0@*~A_~1@*~A_index ON ~0@*~A USING ~2@*~A (~1@*~A)"
 640           (s-sql:to-sql-name table)
 641           (s-sql:to-sql-name field)
 642           (s-sql:to-sql-name index-type)))
 643
 644 (defclass point-template ()
 645   (;; We need a slot point-id which is defined in our subclasses.
 646    (random
 647     :col-type integer
 648     :initform (random (expt 2 31))
 649     :documentation "Used for quickly getting an evenly distributed sample of all points.")
 650    (measurement-id
 651     :writer (setf measurement-id)
 652     :col-type integer)
 653    (event-number
 654     :documentation "Event that triggered this record.  Taken from the GPS file name: ...eventN.txt gives an event number N.  May be a string of any length.")
 655    (gps-time
 656     :reader gps-time
 657     :documentation "UTC calculated from GPS week time.")
 658    (trigger-time
 659     :writer (setf trigger-time)
 660     :col-type double-precision
 661     :documentation "Time in seconds from 1900.  Values before 1980-01-06T00:00:00Z are considered invalid.")
 662    (roll
 663     :col-type double-precision)
 664    (pitch
 665     :col-type double-precision)
 666    (heading
 667     :col-type double-precision)
 668    (east-velocity
 669     :col-type double-precision)
 670    (north-velocity
 671     :col-type double-precision)
 672    (up-velocity
 673     :col-type double-precision)
 674    (east-sd
 675     :col-type double-precision)
 676    (north-sd
 677     :col-type double-precision)
 678    (height-sd
 679     :col-type double-precision)
 680    (roll-sd
 681     :col-type double-precision)
 682    (pitch-sd
 683     :col-type double-precision)
 684    (heading-sd
 685     :col-type double-precision)
 686    (longitude
 687     :reader longitude
 688     :documentation "Same content as in slot coordinates.")
 689    (latitude
 690     :reader latitude
 691     :documentation "Same content as in slot coordinates.")
 692    (ellipsoid-height
 693     :reader ellipsoid-height
 694     :documentation "Same content as in slot coordinates.")
 695    (coordinates
 696     :col-type (or db-null geometry)
 697     :documentation "Geographic coordinates.")
 698    (easting
 699     :reader easting
 700     :documentation "In the same coordinate system as the standard deviations.")
 701    (northing
 702     :reader northing
 703     :documentation "In the same coordinate system as the standard deviations.")
 704    (cartesian-height
 705     :reader cartesian-height
 706     :documentation "In the same coordinate system as the standard deviations."))
 707   (:metaclass dao-class)
 708   (:keys point-id)
 709   (:documentation "Information about one GPS point, originally from applanix/**/*event*.txt.  There shouldn't be any point-id without a matching one in the *-image table.  This can't be enforced on database level.  Use (delete-imageless-points acquisition-project) to maintain referential integrity."))
 710
 711 (defclass image-template ()
 712   ((measurement-id
 713     :writer (setf measurement-id)
 714     :col-type integer
 715     :documentation "A primary key.  We need to recognize images should they come in twice, perhaps with slightly changed point data.  In such a case we want the old ones superseded.")
 716    (filename
 717     :reader filename
 718     :initarg :filename
 719     :col-type text
 720     :documentation "Name without any directory components.")
 721    (byte-position
 722     :reader image-byte-position
 723     :initarg :byte-position
 724     :col-type bigint
 725     :documentation "Start of image in .pictures file named by slot filename.")
 726    (point-id
 727     :accessor point-id
 728     :col-type integer)
 729    (recorded-device-id
 730     :initarg :recorded-device-id
 731     :reader recorded-device-id
 732     :col-type text
 733     :documentation "As found in .pictures file, header tag `cam=´.")
 734    (footprint
 735     :initarg :footprint
 736     :col-type (or db-null geometry)
 737     :documentation "Polygon on the ground describing the approximate area covered by this image.")
 738    (footprint-device-stage-of-life-id
 739     :initarg :footprint-device-stage-of-life-id
 740     :col-type (or db-null integer)
 741     :documentation "device-stage-of-life denoting the set of calibration data the footprint of this record has been calculated with.")
 742    (gain
 743     :initarg :gain
 744     :col-type double-precision
 745     :documentation "Camera parameter. TODO: needs a decent definition")
 746    (shutter
 747     :initarg :shutter
 748     :col-type double-precision
 749     :documentation "Camera parameter. TODO: needs a decent definition")
 750    (trigger-time
 751     :initarg :trigger-time
 752     :accessor trigger-time
 753     :documentation "Time in seconds from 1900-01-01.")
 754    (fake-trigger-time-p
 755     :accessor fake-trigger-time-p
 756     :initform nil
 757     :documentation "T if trigger-time has been reconstructed from adjacent data.")
 758    (camera-timestamp
 759     :initarg :camera-timestamp
 760     :reader camera-timestamp
 761     :documentation "Some camera clocktick count starting at an unknown origin."))
 762   (:metaclass dao-class)
 763   (:keys measurement-id filename byte-position)
 764   (:documentation "One row per image, originating from a .pictures file."))
 765
 766 (defclass user-point-template ()
 767   (;; We need a slot user-point-id which is defined in our subclasses.
 768    (user-id
 769     :initarg :user-id
 770     :col-type (or db-null ;when store-user-points is fed an unknown user-name
 771                   integer)
 772     :documentation "User who stored this point.")
 773    (kind
 774     :initarg :kind
 775     :col-type text
 776     :documentation "Class of this user point.")
 777    (description
 778     :initarg :description
 779     :col-type text
 780     :documentation "User comment regarding this point.")
 781    (numeric-description
 782     :initarg :numeric-description
 783     :col-type text
 784     :documentation "User-generated point id regarding this point.")
 785    (creation-date
 786     :col-type :timestamp-with-time-zone
 787     :documentation "Creation time of this point.")
 788    (coordinates
 789     :col-type (or db-null geometry)
 790     :documentation "Geographic coordinates.")
 791    ;; (stdx-global
 792    ;;  :initarg :stdx-global
 793    ;;  :col-type double-precision
 794    ;;  :documentation "Component of standard deviation, in metres.")
 795    ;; (stdy-global
 796    ;;  :initarg :stdy-global
 797    ;;  :col-type double-precision
 798    ;;  :documentation "Component of standard deviation, in metres.")
 799    ;; (stdz-global
 800    ;;  :initarg :stdz-global
 801    ;;  :col-type double-precision
 802    ;;  :documentation "Component of standard deviation, in metres.")
 803    (input-size
 804     :initarg :input-size
 805     :col-type integer
 806     :documentation "Number of points (from different images) used for calculation.")
 807    (aux-numeric
 808     :col-type (or db-null numeric[])
 809     :documentation "Arbitrary numeric values from auxiliary point table.")
 810    (aux-text
 811     :col-type (or db-null text[])
 812     :documentation "Arbitrary text values from auxiliary point table."))
 813   (:metaclass dao-class)
 814   (:keys user-point-id)
 815   (:documentation "Points defined by users."))
 816
 817 (defclass point-data (point-template)
 818   ((point-id
 819     :accessor point-id
 820     :initform nil
 821     :col-type integer
 822     :col-default nil)                   ;to be redefined
 823    point-id-sequence-name)              ;to be redefined
 824   (:metaclass dao-class)
 825   (:table-name nil))                    ;to be redefined
 826
 827 (defclass image-data (image-template)
 828   ()
 829   (:metaclass dao-class)
 830   (:table-name nil))                    ;to be redefined
 831
 832 (defclass user-point-data (user-point-template)
 833   ((user-point-id
 834     :accessor user-point-id
 835     :initform nil
 836     :col-type integer
 837     :col-default nil)                   ;to be redefined
 838    user-point-id-sequence-name)         ;to be redefined)
 839   (:metaclass dao-class)
 840   (:table-name nil))                    ;to be redefined
 841
 842 (let ((table-prefix "dat-"))
 843   (defun point-data-table-name (common-table-name)
 844     (make-symbol (format nil "~A~A-point"
 845                          table-prefix common-table-name)))
 846
 847   (defun image-data-table-name (common-table-name)
 848     (make-symbol (format nil "~A~A-image"
 849                          table-prefix common-table-name)))
 850
 851   (defun point-id-seq-name (common-table-name)
 852     (make-symbol (format nil "~A~A-point-id-seq"
 853                          table-prefix common-table-name)))
 854
 855   (defun aggregate-view-name (common-table-name)
 856     (make-symbol (format nil "~A~A-aggregate"
 857                          table-prefix common-table-name)))
 858
 859   (defun aggregate-view-update-rule-name (common-table-name)
 860     (make-symbol (format nil "~A~A-aggregate-update"
 861                          table-prefix common-table-name))))
 862
 863 (let ((table-prefix "usr-"))
 864   (defun user-point-table-name (presentation-project-name)
 865     (make-symbol (format nil "~A~A-point"
 866                          table-prefix presentation-project-name)))
 867
 868   (defun user-point-id-seq-name (presentation-project-name)
 869     (make-symbol (format nil "~A~A-point-id-seq"
 870                          table-prefix presentation-project-name)))
 871
 872   (defun user-line-table-name (presentation-project-name)
 873     (make-symbol (format nil "~A~A-line"
 874                          table-prefix presentation-project-name))))
 875
 876 (let ((table-prefix "phoros-"))
 877   ;; This stuff may reside in a foreign database so we show explicitly
 878   ;; what it belongs to.
 879   (defun aux-point-view-name (presentation-project-name)
 880     (make-symbol (format nil "~A~A-aux-point"
 881                          table-prefix presentation-project-name)))
 882
 883   (defun thread-aux-points-function-name (presentation-project-name)
 884     (make-symbol (format nil "~A~A-thread-aux-points"
 885                           table-prefix presentation-project-name))))
 886
 887 (defun create-data-table-definitions (common-table-name)
 888   "Define or redefine a bunch of dao-classes which can hold measuring
 889 data and which are connected to database tables named
 890 common-table-name plus type-specific prefix and suffix."
 891   (let ((image-data-table-name
 892          (image-data-table-name common-table-name))
 893         (point-data-table-name
 894          (point-data-table-name common-table-name))
 895         (point-id-sequence-name
 896          (point-id-seq-name common-table-name)))
 897     (eval
 898      `(defclass point-data (point-template)
 899         ((point-id
 900           :accessor point-id
 901           :initform nil
 902           :col-type integer
 903           :col-default (:nextval ,point-id-sequence-name)) ; redefinition
 904          (point-id-sequence-name
 905           :initform ,(string point-id-sequence-name) ; redefinition
 906           :reader point-id-sequence-name
 907           :allocation :class))
 908         (:metaclass dao-class)
 909         (:table-name ,point-data-table-name))) ;redefinition
 910     (deftable point-data
 911       (:create-sequence point-id-sequence-name)
 912       (!dao-def)
 913       (!!index point-data-table-name 'random)
 914       (!!index point-data-table-name 'measurement-id)
 915       (!!index point-data-table-name 'trigger-time)
 916       (!!index point-data-table-name 'coordinates :index-type :gist)
 917       (!!index point-data-table-name 'point-id)
 918       ;; The following let shouldn't be necessary. (Wart In !foreign.)
 919       (let ((*table-symbol* point-data-table-name)
 920             (*table-name*  (s-sql:to-sql-name point-data-table-name)))
 921         (!foreign 'sys-measurement 'measurement-id
 922                   :on-delete :cascade :on-update :cascade)))
 923     (eval
 924      `(defclass image-data (image-template)
 925         ()
 926         (:metaclass dao-class)
 927         (:table-name ,image-data-table-name))) ; redefintion
 928     (deftable image-data
 929       (!dao-def)
 930       (!!index image-data-table-name 'measurement-id)
 931       (!!index image-data-table-name 'recorded-device-id)
 932       (!!index image-data-table-name 'point-id)
 933       ;; (!!index image-data-table-name 'gain)
 934       ;; (!!index image-data-table-name 'shutter)
 935       (!!index image-data-table-name 'footprint :index-type :gist)
 936       ;; The following let shouldn't be necessary. (Wart in !foreign.)
 937       (let ((*table-symbol* image-data-table-name)
 938             (*table-name*  (s-sql:to-sql-name image-data-table-name)))
 939         (!foreign point-data-table-name 'point-id
 940                   :on-delete :cascade :on-update :cascade)
 941         (!foreign 'sys-measurement 'measurement-id
 942                   :on-delete :cascade :on-update :cascade)))))
 943
 944 (defun create-user-table-definition (presentation-project-name)
 945   "Define or redefine a dao-class which can hold user points and which
 946 is connected to a database table named presentation-project-name plus
 947 type-specific prefix and suffix."
 948   (let ((user-point-table-name
 949          (user-point-table-name presentation-project-name))
 950         (user-point-id-sequence-name
 951          (user-point-id-seq-name presentation-project-name)))
 952     (eval
 953      `(defclass user-point (user-point-template)
 954         ((user-point-id
 955           :accessor point-id
 956           :initform nil
 957           :col-type integer
 958           :col-default (:nextval ,user-point-id-sequence-name))) ; redefinition
 959         (:metaclass dao-class)
 960         (:table-name ,user-point-table-name))) ;redefinition
 961     (deftable user-point
 962       (:create-sequence user-point-id-sequence-name)
 963       (!dao-def)
 964       (!!index user-point-table-name 'coordinates :index-type :gist))))
 965
 966 (defun create-aggregate-view (common-table-name)
 967   "Create a view of a set of measuring and calibration data
 968 belonging to images."
 969   (let ((image-data-table-name (image-data-table-name common-table-name))
 970         (point-data-table-name (point-data-table-name common-table-name))
 971         (aggregate-view-name (aggregate-view-name common-table-name))
 972         (aggregate-view-update-rule-name (aggregate-view-update-rule-name
 973                                           common-table-name)))
 974     (eval
 975      `(execute
 976        (:create-view
 977         ,aggregate-view-name
 978         (:select
 979          'sys-device-stage-of-life.recorded-device-id      ;debug
 980          'sys-device-stage-of-life.device-stage-of-life-id ;debug
 981          'sys-device-stage-of-life.generic-device-id       ;debug
 982          'random
 983          'presentation-project-id
 984          'directory
 985          (:dot ',image-data-table-name 'measurement-id)
 986          'filename 'byte-position
 987          (:dot ',point-data-table-name 'point-id)
 988          'footprint 'footprint-device-stage-of-life-id
 989          'trigger-time
 990          'coordinates                   ;the search target
 991          (:as (:st_x (:st_transform 'coordinates *standard-coordinates*))
 992               'longitude)
 993          (:as (:st_y (:st_transform 'coordinates *standard-coordinates*))
 994               'latitude)
 995          (:as (:st_z (:st_transform 'coordinates *standard-coordinates*))
 996               'ellipsoid-height)
 997          'cartesian-system
 998          'east-sd 'north-sd 'height-sd
 999          'roll 'pitch 'heading 'roll-sd 'pitch-sd 'heading-sd
1000          'usable
1001          'sensor-width-pix 'sensor-height-pix 'pix-size
1002          'bayer-pattern 'color-raiser
1003          'mounting-angle
1004          'dx 'dy 'dz 'omega 'phi 'kappa
1005          'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
1006          'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
1007          'b-ddx 'b-ddy 'b-ddz 'b-drotx 'b-droty 'b-drotz
1008          'nx 'ny 'nz 'd
1009          :from
1010          'sys-measurement
1011          'sys-presentation
1012          ',point-data-table-name ',image-data-table-name
1013          'sys-device-stage-of-life 'sys-generic-device 'sys-camera-hardware
1014          'sys-camera-calibration
1015          :where
1016          (:and
1017           (:= (:dot ',image-data-table-name 'measurement-id)
1018               'sys-presentation.measurement-id)
1019           (:= 'sys-presentation.measurement-id
1020               'sys-measurement.measurement-id)
1021           (:= (:dot ',point-data-table-name 'point-id)
1022               (:dot ',image-data-table-name 'point-id))
1023           (:= (:dot ',image-data-table-name 'recorded-device-id)
1024               'sys-device-stage-of-life.recorded-device-id)
1025           (:= 'sys-generic-device.generic-device-id
1026               'sys-device-stage-of-life.generic-device-id)
1027           (:= 'sys-camera-hardware.camera-hardware-id
1028               'sys-generic-device.camera-hardware-id)
1029           (:= 'sys-device-stage-of-life.device-stage-of-life-id
1030               'sys-camera-calibration.device-stage-of-life-id)
1031           (:= 'sys-device-stage-of-life.device-stage-of-life-id
1032               (:limit
1033                (:order-by
1034                 (:select 'sys-camera-calibration.device-stage-of-life-id
1035                          :from 'sys-camera-calibration
1036                          :where
1037                          (:= 'sys-device-stage-of-life.device-stage-of-life-id
1038                              'sys-camera-calibration.device-stage-of-life-id))
1039                 (:desc 'date))
1040                1))
1041           (:<= (:extract :epoch 'sys-device-stage-of-life.mounting-date)
1042                (:- (:dot ',point-data-table-name 'trigger-time)
1043                    *unix-epoch*))
1044           (:or (:is-null 'sys-device-stage-of-life.unmounting-date)
1045                (:>= (:extract :epoch 'sys-device-stage-of-life.unmounting-date)
1046                     (:- (:dot ',point-data-table-name 'trigger-time)
1047                         *unix-epoch*))))))))
1048     (execute
1049      (format
1050       nil
1051       "CREATE OR REPLACE RULE ~A ~
1052          AS ON UPDATE TO ~A DO INSTEAD ~
1053            UPDATE ~A ~
1054              SET footprint = NEW.footprint, ~
1055              footprint_device_stage_of_life_id = OLD.device_stage_of_life_id
1056              WHERE byte_position = OLD.byte_position ~
1057                AND filename = OLD.filename ~
1058                AND measurement_id = OLD.measurement_id;"
1059       (s-sql:to-sql-name aggregate-view-update-rule-name)
1060       (s-sql:to-sql-name aggregate-view-name)
1061       (s-sql:to-sql-name image-data-table-name)))))
1062
1063 (defun aux-view-exists-p (presentation-project-name)
1064   "See if there is a view into auxiliary point table that belongs to
1065 presentation-project-name."
1066   (view-exists-p (aux-point-view-name presentation-project-name)))
1067
1068 (defun delete-aux-view (presentation-project-name)
1069   "Delete the view into auxiliary point table that belongs to
1070 presentation-project-name."
1071   (execute (format nil "DROP VIEW ~A CASCADE;"
1072                    (s-sql:to-sql-name (aux-point-view-name
1073                                        presentation-project-name))))
1074   (execute
1075    (format nil "DROP FUNCTION IF EXISTS ~
1076                 ~A(GEOMETRY, DOUBLE PRECISION, INT, DOUBLE PRECISION);"
1077            (s-sql:to-sql-name (thread-aux-points-function-name
1078                                presentation-project-name)))))
1079
1080 (defun* create-aux-view (presentation-project-name
1081                         &key (coordinates-column :the-geom)
1082                         numeric-columns text-columns
1083                         &mandatory-key aux-table)
1084   "Create a view into aux-table and an SQL function for threading
1085 aux-points into a linestring.  coordinates-column goes into column
1086 coordinates, numeric-columns and text-columns go into arrays in
1087 aux-numeric and aux-text respectively.
1088
1089 aux-table should have an index like so:
1090
1091 CREATE INDEX idx_<aux-table>_the_geom
1092   ON <aux-table>
1093   USING gist (the_geom);
1094
1095 VACUUM FULL ANALYZE <aux-table> (the_geom);"
1096   (create-plpgsql-helpers)
1097   (flet ((to-sql-name-or-null (name)
1098            (if name
1099                (s-sql:to-sql-name name)
1100                :null)))
1101     (let ((aux-point-view-name
1102            (aux-point-view-name presentation-project-name))
1103           (thread-aux-points-function-name
1104            (thread-aux-points-function-name presentation-project-name))
1105           (srid-count
1106            (query
1107             (:select (:as (:select (:count t)
1108                                    :from (make-symbol aux-table)
1109                                    :where (:<> (:st_srid (make-symbol coordinates-column))
1110                                                *standard-coordinates*))
1111                           'bad)
1112                      (:as (:select (:count (make-symbol coordinates-column))
1113                                    :from (make-symbol aux-table))
1114                           'total))
1115             :plist)))
1116       (unless (zerop (getf srid-count :bad))
1117         (warn "In column ~A of auxiliary data table ~A, ~D out of ~D values ~
1118               have currently an unsuitable SRID not equal to ~D."
1119               coordinates-column aux-table
1120               (getf srid-count :bad) (getf srid-count :total)
1121               *standard-coordinates*))
1122       (execute (format nil "
1123 CREATE VIEW ~A
1124 AS (SELECT ~A AS coordinates,
1125     ~:[NULL~;ARRAY[~:*~{~A~#^, ~}]~] AS aux_numeric,
1126     ~:[NULL~;ARRAY[~:*~{~A~#^, ~}]~] AS aux_text
1127     FROM ~A)"
1128                        (s-sql:to-sql-name aux-point-view-name)
1129                        (s-sql:to-sql-name coordinates-column)
1130                        (mapcar #'to-sql-name-or-null numeric-columns)
1131                        (mapcar #'to-sql-name-or-null text-columns)
1132                        (s-sql:to-sql-name aux-table)))
1133       (execute (format nil "~
1134 CREATE OR REPLACE FUNCTION ~0@*~A
1135   (point GEOMETRY, sample_radius DOUBLE PRECISION, sample_size INT,
1136    step_size DOUBLE PRECISION, old_azimuth DOUBLE PRECISION,
1137    max_bend DOUBLE PRECISION,
1138    OUT threaded_points TEXT,
1139    OUT current_point TEXT,
1140    OUT back_point TEXT, OUT forward_point TEXT,
1141    OUT new_azimuth DOUBLE PRECISION)
1142 AS
1143 $$
1144 -- Phoros version ~2@*~A
1145 DECLARE
1146   point_bag_size INT;
1147   current_point_position DOUBLE PRECISION;
1148   location DOUBLE PRECISION;
1149   line GEOMETRY;
1150   new_point point_bag%ROWTYPE;
1151   tried_point point_bag%ROWTYPE;
1152   previous_point point_bag%ROWTYPE;
1153   starting_point GEOMETRY;
1154   reversal_count INT DEFAULT 0;
1155 BEGIN
1156   -- Muffle warnings about implicitly created stuff:
1157   SET client_min_messages TO ERROR;
1158
1159   starting_point :=
1160     (SELECT coordinates
1161        FROM ~1@*~A
1162        WHERE
1163          coordinates
1164          &&
1165          st_setsrid(st_makebox3d (st_translate (point,
1166                                                 - sample_radius * 5,
1167                                                 - sample_radius * 5, 0),
1168                                   st_translate (point,
1169                                                 sample_radius * 5,
1170                                                 sample_radius * 5, 0)),
1171                     4326)
1172        ORDER BY st_distance(coordinates, point)
1173        LIMIT 1);
1174
1175   CREATE TEMPORARY TABLE point_bag
1176     (id SERIAL primary key, coordinates GEOMETRY)
1177     ON COMMIT DROP;
1178
1179   INSERT INTO point_bag (coordinates)
1180     SELECT coordinates
1181       FROM ~1@*~A
1182
1183       WHERE
1184         coordinates
1185         &&
1186         st_setsrid(st_makebox3d (st_translate (starting_point,
1187                                                - sample_radius,
1188                                                - sample_radius, 0),
1189                                  st_translate (starting_point,
1190                                                sample_radius,
1191                                                sample_radius, 0)),
1192                    4326)
1193         AND st_distance (coordinates, starting_point) < sample_radius
1194       ORDER BY st_distance (coordinates, starting_point)
1195       LIMIT sample_size;
1196
1197   point_bag_size := (SELECT count(*) from point_bag);
1198
1199   -- emergency point_bag:
1200   IF point_bag_size < 5
1201   THEN
1202     DROP TABLE point_bag;
1203     CREATE TEMPORARY TABLE point_bag
1204       (id SERIAL primary key, coordinates GEOMETRY)
1205       ON COMMIT DROP;
1206     INSERT INTO point_bag (coordinates)
1207       SELECT coordinates
1208         FROM ~1@*~A
1209         WHERE
1210           coordinates
1211           &&
1212           st_setsrid(st_makebox3d (st_translate (point,
1213                                                  - sample_radius * 100,
1214                                                  - sample_radius * 100, 0),
1215                                    st_translate (point,
1216                                                  sample_radius * 100,
1217                                                  sample_radius * 100, 0)),
1218                      4326)
1219         ORDER BY st_distance (coordinates, starting_point)
1220         LIMIT 5;
1221     starting_point := (SELECT coordinates FROM point_bag where id = 3);
1222   END IF;
1223
1224   previous_point :=
1225     (SELECT ROW(id, coordinates)
1226        FROM point_bag
1227        ORDER BY st_distance (point_bag.coordinates, starting_point)
1228        LIMIT 1);
1229
1230   DELETE FROM point_bag WHERE id = previous_point.id;
1231
1232   new_point :=
1233     (SELECT ROW(id, coordinates)
1234        FROM point_bag
1235        ORDER BY st_distance (point_bag.coordinates, previous_point.coordinates)
1236        LIMIT 1);
1237
1238   line := st_makeline(previous_point.coordinates,
1239                       new_point.coordinates);
1240
1241   new_azimuth :=
1242     st_azimuth(previous_point.coordinates, new_point.coordinates);
1243
1244   IF abs(new_azimuth - old_azimuth) > radians(90)
1245      AND
1246      abs(new_azimuth - old_azimuth) < radians(270)
1247   THEN
1248     new_azimuth :=
1249       st_azimuth(new_point.coordinates, previous_point.coordinates);
1250     line := st_reverse(line);
1251   END IF;
1252
1253   DELETE FROM point_bag WHERE id = new_point.id;
1254
1255   LOOP
1256     previous_point.coordinates := st_pointn(line,1);
1257
1258     new_point :=
1259       (SELECT ROW(id, coordinates)
1260          FROM point_bag
1261          ORDER BY st_distance (coordinates, previous_point.coordinates)
1262          LIMIT 1);
1263
1264     EXIT WHEN new_point IS NULL;
1265
1266     IF bendedness(st_pointn(line, 2), st_pointn(line, 1),
1267                   new_point.coordinates)
1268        < bendedness(st_pointn(line, st_npoints(line) - 1),
1269                     st_pointn(line, st_npoints(line)), new_point.coordinates)
1270        AND
1271        bendedness(st_pointn(line, 2), st_pointn(line, 1),
1272                    new_point.coordinates)
1273        < max_bend
1274     THEN
1275         line := st_addpoint(line, new_point.coordinates, 0);
1276         DELETE FROM point_bag WHERE id = new_point.id;
1277     END IF;
1278
1279     line := st_reverse(line);
1280
1281     reversal_count := reversal_count + 1 ;
1282
1283     DELETE FROM point_bag WHERE id = tried_point.id;
1284
1285     tried_point := new_point;
1286   END LOOP;
1287
1288   IF mod(reversal_count, 2) = 1
1289   THEN
1290     line := st_reverse(line);
1291   END IF;
1292
1293   current_point_position :=
1294     st_line_locate_point(line, point);
1295
1296   current_point :=
1297     st_astext(st_line_interpolate_point(line, current_point_position));
1298
1299   location := (current_point_position - (step_size / st_length(line)));
1300   IF location < 0 THEN location := 0; END IF;
1301
1302   back_point :=
1303     st_astext(st_line_interpolate_point(line, location));
1304
1305   location := (current_point_position + (step_size / st_length(line)));
1306   IF location > 0 THEN location := 1; END IF;
1307
1308   forward_point :=
1309     st_astext(st_line_interpolate_point(line, location));
1310
1311   threaded_points := st_astext(line);
1312
1313   RETURN;
1314 END;
1315 $$ LANGUAGE plpgsql;"
1316                        (s-sql:to-sql-name thread-aux-points-function-name)
1317                        (s-sql:to-sql-name aux-point-view-name)
1318                        (phoros-version))))))
1319
1320 (defun create-acquisition-project (common-table-name)
1321   "Create in current database a fresh set of canonically named tables.
1322 common-table-name should in most cases resemble the project name and
1323 will be stored in table sys-acquisition-project, field
1324 common-table-name."
1325   (create-data-table-definitions common-table-name)
1326   (handler-case (create-sys-tables) ;Create system tables if necessary.
1327     (cl-postgres-error:syntax-error-or-access-violation () nil))
1328   (assert-phoros-db-major-version)
1329   (when (select-dao 'sys-acquisition-project
1330                     (:= 'common-table-name common-table-name))
1331     (error "There is already an acquisition project by the name of ~A."
1332            common-table-name))
1333   (create-table 'point-data)
1334   (create-table 'image-data)
1335   (create-aggregate-view common-table-name)
1336   (insert-dao
1337    (make-instance 'sys-acquisition-project
1338                   :common-table-name common-table-name)))
1339
1340 (defun delete-acquisition-project (common-table-name)
1341   "Delete the acquisition project that uses common-table-name.  Return
1342 nil if there wasn't any."
1343   (assert-phoros-db-major-version)
1344   (let ((project
1345          (car (select-dao 'sys-acquisition-project
1346                           (:= 'common-table-name common-table-name)))))
1347     (when project
1348       (delete-dao project)
1349       (execute (:drop-view
1350                 :if-exists (aggregate-view-name common-table-name)))
1351       (execute (:drop-table
1352                 :if-exists (image-data-table-name common-table-name)))
1353       (execute (:drop-table
1354                 :if-exists (point-data-table-name common-table-name)))
1355       (execute (:drop-sequence
1356                 :if-exists (point-id-seq-name common-table-name))))))
1357
1358 (defun delete-measurement (measurement-id)
1359   "Delete measurement with measurement-id if any; return nil if not."
1360   (assert-phoros-db-major-version)
1361   (let ((measurement (get-dao 'sys-measurement measurement-id)))
1362     (when measurement (delete-dao measurement))))
1363
1364 (defun create-presentation-project (project-name)
1365   "Create a fresh presentation project in current database.  Return
1366 dao if one was created, or nil if it existed already."
1367   (assert-phoros-db-major-version)
1368   (unless (get-dao 'sys-presentation-project project-name)
1369     (create-user-table-definition project-name)
1370     (create-table 'user-point)
1371     (create-presentation-project-trigger-function project-name)
1372     (execute (format nil "DROP TRIGGER IF EXISTS ~A ON ~:*~A;"
1373                      (s-sql:to-sql-name (user-point-table-name project-name))))
1374     (execute (format nil "
1375 CREATE TRIGGER ~A
1376   AFTER INSERT OR UPDATE OR DELETE
1377   ON ~:*~A
1378   FOR EACH ROW EXECUTE PROCEDURE ~:*~A();"
1379                      (s-sql:to-sql-name (user-point-table-name project-name))))
1380     (execute (sql-compile
1381               `(:create-table ,(user-line-table-name project-name)
1382                               ((description :type text)
1383                                ;; description would be a nice primary
1384                                ;; key if it wasn't for QGIS which
1385                                ;; needs it numeric
1386                                (id :type serial :primary-key t)
1387                                (line :type geometry)))))
1388     (insert-dao (make-instance 'sys-presentation-project
1389                                :presentation-project-name project-name))))
1390
1391 (defun create-presentation-project-trigger-function
1392     (presentation-project
1393      &optional (plpgsql-body
1394                 (format
1395                  nil "  RAISE NOTICE 'trigger fired: ~A';"
1396                  (s-sql:to-sql-name (user-point-table-name
1397                                      presentation-project))))
1398      &rest plpgsql-body-args)
1399   "(Re)create in current database an SQL trigger function with
1400 plpgsql-body (a format string that uses plpgsql-body-args)."
1401   (execute (format
1402             nil "
1403 CREATE OR REPLACE FUNCTION ~A() RETURNS trigger
1404 AS
1405 $$
1406 BEGIN
1407   ------------------------------------------
1408   -- Define your trigger actions below:
1409   ------------------------------------------
1410 ~?~&~:
1411   ------------------------------------------
1412   -- End of your trigger action definitions.
1413   ------------------------------------------
1414   RETURN NULL;
1415 END;
1416 $$ LANGUAGE plpgsql;"
1417             (s-sql:to-sql-name (user-point-table-name presentation-project))
1418             plpgsql-body
1419             plpgsql-body-args)))
1420
1421 (defun fire-presentation-project-trigger-function (presentation-project)
1422   "Tickle user point table of presentation-project so it fires its
1423 trigger."
1424   (let ((user-point-table (user-point-table-name presentation-project)))
1425     (execute
1426      (:update user-point-table
1427               :set 'user-point-id 'user-point-id
1428               :where (:= 'user-point-id
1429                          (:limit (:select 'user-point-id
1430                                           :from user-point-table) 1))))))
1431
1432 (defun delete-presentation-project (project-name)
1433   "Delete the presentation project project-name.  Return nil if there
1434 wasn't any."
1435   (assert-phoros-db-major-version)
1436   (let ((project (get-dao 'sys-presentation-project project-name)))
1437     (when project
1438       (delete-dao project)
1439       (execute
1440        (:drop-table :if-exists (user-point-table-name project-name)))
1441       (execute
1442        (:drop-sequence :if-exists (user-point-id-seq-name project-name)))
1443       (execute
1444        (:drop-table :if-exists (user-line-table-name project-name))))))
1445
1446 (defun postmodern-as-clauses (row-alist)
1447   "Make a list of constant :as clauses from query result row-alist.
1448 Alias names are the column names from row-alist prefixed by first-."
1449   (loop
1450      for column in row-alist
1451      collect `(:as
1452                ,(cdr column)
1453                ,(intern (string (prefix-aggregate-view-column (car column)))
1454                         'keyword))))
1455
1456 (defun prefix-aggregate-view-column (column-name)
1457   "Return a symbol named column-name, prefixed by first-."
1458   (make-symbol (concatenate 'string
1459                             (string 'first-)
1460                             (string column-name))))
1461
1462 (defun some-internal-image-reference (sql-clause)
1463   "Return t if there are occurences of
1464 first-<something-from-*aggregate-view-columns*>, which act as
1465 references to the first image."
1466   (loop
1467      for i in *aggregate-view-columns*
1468      thereis
1469        (ppcre:scan
1470         (ppcre:create-scanner
1471          (s-sql:to-sql-name (prefix-aggregate-view-column i))
1472          :case-insensitive-mode
1473          t)
1474         sql-clause)))
1475
1476 (defun* create-image-attribute (presentation-project-name
1477                                &mandatory-key tag sql-clause)
1478   "Store a boolean SQL expression into current database.  Return SQL
1479 expression previously stored for presentation-project-name and tag if
1480 any; return nil otherwise.  Second return value is the number of
1481 images covered by the SQL expression, and third return value is the
1482 total number of images in presentation project.  Both second and third
1483 return value are nil if sql-clause contains references to the first
1484 image."
1485   (assert-phoros-db-major-version)
1486   (let* ((presentation-project-id
1487           (presentation-project-id-from-name presentation-project-name))
1488          (old-selectable-restriction
1489           (get-dao 'sys-selectable-restriction presentation-project-id tag))
1490          (common-table-names
1491           (common-table-names presentation-project-id))
1492          (empty-presentation-project-p (null common-table-names))
1493          (selected-restrictions-conjunction
1494           (sql-where-conjunction (list sql-clause)))
1495          (arbitrary-image-query
1496           (sql-compile
1497            `(:union
1498              ,@(loop
1499                   for common-table-name in common-table-names
1500                   for aggregate-view-name
1501                   = (aggregate-view-name common-table-name)
1502                   collect
1503                     `(:limit (:select ,@*aggregate-view-columns*
1504                                       :from ',aggregate-view-name)
1505                              1)))))
1506          (internal-reference-p (some-internal-image-reference sql-clause))
1507          (arbitrary-image (unless empty-presentation-project-p
1508                             (query arbitrary-image-query :alist)))
1509          (counting-selected-query
1510           ;; Only useful as an SQL syntax check if sql-clause contains
1511           ;; internal references.
1512           (sql-compile
1513            `(:select
1514              (:sum count)
1515              :from
1516              (:as
1517               (:union
1518                ,@(loop
1519                     for common-table-name in common-table-names
1520                     for aggregate-view-name
1521                     = (aggregate-view-name common-table-name)
1522                     collect
1523                     `(:select
1524                       (:as (:count t) 'count)
1525                       :from
1526                       (:as
1527                        (:select
1528                         ,@(postmodern-as-clauses arbitrary-image)
1529                         '*
1530                         :from ',aggregate-view-name)
1531                        'images-of-acquisition-project-plus-reference-image)
1532                       :where
1533                       (:and (:= 'presentation-project-id
1534                                 ,presentation-project-id)
1535                             (:raw ,selected-restrictions-conjunction)))))
1536               'acquisition-project-image-counts))))
1537          (counting-total-query
1538           (sql-compile
1539            `(:select
1540              (:sum count)
1541              :from
1542              (:as (:union
1543                    ,@(loop
1544                         for common-table-name in common-table-names
1545                         for aggregate-view-name
1546                         = (aggregate-view-name common-table-name)
1547                         collect
1548                         `(:select
1549                           (:as (:count '*) 'count)
1550                           :from ',aggregate-view-name
1551                           :where (:= 'presentation-project-id
1552                                      ,presentation-project-id))))
1553                   'acquisition-project-image-counts))))
1554          (number-of-selected-images
1555           (if empty-presentation-project-p
1556               0
1557               (query counting-selected-query :single!)))
1558          (total-number-of-images
1559           (unless internal-reference-p    ;otherwise don't waste time
1560             (if empty-presentation-project-p
1561                 0
1562                 (query counting-total-query :single!)))))
1563     (save-dao (make-instance 'sys-selectable-restriction
1564                              :presentation-project-id presentation-project-id
1565                              :restriction-id tag :sql-clause sql-clause))
1566     (values
1567      (when old-selectable-restriction (sql-clause old-selectable-restriction))
1568      (if internal-reference-p nil number-of-selected-images)
1569      (if internal-reference-p nil total-number-of-images))))
1570
1571 (defun* delete-image-attribute (presentation-project-name &mandatory-key tag)
1572   "Delete SQL expression stored with tag under
1573 presentation-project-name from current database.  Return the SQL
1574 expression deleted if there was any; return nil otherwise."
1575   (assert-phoros-db-major-version)
1576   (let ((selectable-restriction
1577          (get-dao 'sys-selectable-restriction
1578                   (presentation-project-id-from-name presentation-project-name)
1579                   tag)))
1580     (when selectable-restriction
1581       (delete-dao selectable-restriction)
1582       (sql-clause selectable-restriction))))
1583
1584 (defun* create-user (name &key
1585                           presentation-projects
1586                           &mandatory-key
1587                           user-password
1588                           user-full-name
1589                           user-role)
1590   "Create a fresh user entry or update an existing one with matching
1591 name.  Assign it presentation-projects, deleting any previously
1592 existing assignments."
1593   (assert-phoros-db-major-version)
1594   (assert (or (string-equal "read" user-role)
1595               (string-equal "write" user-role)
1596               (string-equal "admin" user-role))
1597           (user-role)
1598           "~A is not a valid user-role." user-role)
1599   (let ((user (or (car (select-dao 'sys-user (:= 'user-name name)))
1600                   (make-instance 'sys-user :user-name name)))
1601         fresh-user-p)
1602     (setf (user-password user) user-password
1603           (user-full-name user) user-full-name)
1604     (setf fresh-user-p (save-dao user))
1605     (mapcar #'delete-dao (select-dao 'sys-user-role
1606                                      (:= 'user-id (user-id user))))
1607     (dolist (presentation-project-name presentation-projects)
1608       (let ((presentation-project
1609              (get-dao 'sys-presentation-project presentation-project-name)))
1610         (if presentation-project
1611             (insert-dao
1612              (make-instance
1613               'sys-user-role
1614               :user-id (user-id user)
1615               :presentation-project-id
1616               (presentation-project-id presentation-project)
1617               :user-role (string-downcase user-role))) ;TODO: we should be able to set role per presentation-project.
1618             (warn
1619              "There is no presentation project ~A" presentation-project-name))))
1620     fresh-user-p))
1621
1622 (defun delete-user (user-name)
1623   "Delete user user-name if any; return nil if not."
1624   (assert-phoros-db-major-version)
1625   (let ((user (car (select-dao 'sys-user (:= 'user-name user-name)))))
1626     (when user (delete-dao user))))
1627
1628 (defun add-to-presentation-project (presentation-project-name
1629                                     &key measurement-ids acquisition-project)
1630   "Add to presentation project presentation-project-name either a list
1631 of measurements (with measurement-id) or all measurements currently in
1632 acquisition-project (denoted by its common-table-name)."
1633   (assert-phoros-db-major-version)
1634   (let* ((presentation-project
1635           (car (select-dao 'sys-presentation-project
1636                            (:= 'presentation-project-name
1637                                presentation-project-name))))
1638          (presentation-project-id
1639           (presentation-project-id presentation-project)))
1640     (flet ((add-measurement (measurement-id)
1641              "Add one measurement to the given presentation-project."
1642              (unless (get-dao 'sys-presentation
1643                               presentation-project-id
1644                               measurement-id)
1645                (insert-dao
1646                 (make-instance 'sys-presentation
1647                                :presentation-project-id presentation-project-id
1648                                :measurement-id measurement-id)))))
1649       (cond (measurement-ids (mapc #'add-measurement measurement-ids))
1650             (acquisition-project
1651              (dolist
1652                  (measurement-id
1653                    (query
1654                     (:select
1655                      'measurement-id
1656                      :from 'sys-measurement 'sys-acquisition-project
1657                      :where (:and
1658                              (:= 'sys-acquisition-project.common-table-name
1659                                  acquisition-project)
1660                              (:= 'sys-measurement.acquisition-project-id
1661                                  'sys-acquisition-project.acquisition-project-id)))
1662                     :column))
1663                (add-measurement measurement-id)))
1664             (t (error
1665                 "Don't know what to add.  ~
1666                  Need either measurement-id or acquisition-project."))))
1667     (let* ((common-table-names
1668             (common-table-names presentation-project-id))
1669            (presentation-project-bounding-box
1670             (ignore-errors             ;for empty presentation project
1671               (substitute
1672                #\, #\Space
1673                (string-trim
1674                 "BOX()"
1675                 (query
1676                  (sql-compile
1677                   `(:select
1678                     (:st_extent 'coordinates)
1679                     :from
1680                     (:as (:union
1681                           ,@(loop
1682                                for common-table-name in common-table-names
1683                                for point-table-name
1684                                = (point-data-table-name common-table-name)
1685                                ;; would have been nice, was too slow:
1686                                ;; = (aggregate-view-name common-table-name)
1687                                collect
1688                                `(:select
1689                                  'coordinates
1690                                  :from ',point-table-name
1691                                  :natural :left-join 'sys-presentation
1692                                  :where
1693                                  (:= 'presentation-project-id
1694                                      ,presentation-project-id))))
1695                          all-coordinates)))
1696                  :single!))))))
1697       (when presentation-project-bounding-box
1698         (setf (bounding-box presentation-project)
1699               presentation-project-bounding-box))
1700       (update-dao presentation-project))))
1701
1702 (defun remove-from-presentation-project (presentation-project-name
1703                                          &key measurement-ids acquisition-project)
1704   "Remove from presentation project presentation-project-name either a
1705 list of measurements (with measurement-id) or all measurements
1706 currently in acquisition-project with (denoted by its
1707 common-table-name).  Return nil if there weren't anything to remove."
1708   (assert-phoros-db-major-version)
1709   (let* ((presentation-project
1710           (car (select-dao 'sys-presentation-project
1711                            (:= 'presentation-project-name
1712                                presentation-project-name))))
1713          (presentation-project-id
1714           (Presentation-project-id presentation-project)))
1715     (flet ((remove-measurement (measurement-id)
1716              (let ((measurement
1717                     (car (select-dao
1718                           'sys-presentation
1719                           (:and (:= 'measurement-id measurement-id)
1720                                 (:= 'presentation-project-id
1721                                     presentation-project-id))))))
1722                (when measurement (delete-dao measurement)))))
1723     (cond (measurement-ids (mapc #'remove-measurement measurement-ids))
1724           (acquisition-project
1725            (dolist
1726                (measurement-id
1727                  (query
1728                   (:select
1729                    'measurement-id
1730                    :from 'sys-measurement 'sys-acquisition-project
1731                    :where (:and
1732                            (:= 'sys-acquisition-project.common-table-name
1733                                acquisition-project)
1734                            (:= 'sys-measurement.acquisition-project-id
1735                                'sys-acquisition-project.acquisition-project-id)))
1736                   :column))
1737              (remove-measurement measurement-id)))
1738           (t (error
1739               "Don't know what to remove.  ~
1740                Need either measurement-id or acquisition-project."))))))
1741
1742