db-tables.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
  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   (sql-compile
 127    `(:alter-table ,*table-name* :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-user-role ()
 153   ((user-id
 154     :initarg :user-id
 155     :col-type integer)
 156    (presentation-project-id
 157     :initarg :presentation-project-id
 158     :col-type integer)
 159    (user-role
 160     :initarg :user-role
 161     :col-type text
 162     :documentation "One of read, write, admin.")
 163    (bounding-box
 164     :col-type (or db-null text)
 165     :accessor bounding-box
 166     :documentation "Streetmap zoom extent last time user left Phoros.")
 167    (cursor
 168     :col-type (or db-null geometry)
 169     :accessor cursor
 170     :documentation "Point; users work coordinate in streetmap last time they left Phoros."))
 171   (:metaclass dao-class)
 172   (:keys user-id presentation-project-id))
 173
 174 (deftable sys-user-role
 175   (!dao-def)
 176   (!foreign 'sys-user 'user-id :on-delete :cascade :on-update :cascade)
 177   (!foreign 'sys-presentation-project 'presentation-project-id
 178             :on-delete :cascade :on-update :cascade))
 179
 180 (defclass sys-measurement ()
 181   ((measurement-id
 182     :reader measurement-id
 183     :col-type integer
 184     :col-default (:nextval 'sys-measurement-id-seq))
 185    (acquisition-project-id
 186     :initarg :acquisition-project-id
 187     :col-type integer)
 188    (directory
 189     :initarg :directory
 190     :col-type text
 191     :documentation
 192     "Below some universal root common to all measurements; excluding
 193 `applanix/´ `images/´ etc.
 194
 195 The entire directory structure looks like this:
 196
 197 Points
 198 ======
 199 /some/path/in/our/system/this/measurement/blah/applanix/points/xyz-event1.txt
 200 /some/path/in/our/system/this/measurement/blah/applanix/points/uvw-event2.txt
 201                                           ---- +++++++++++++++ ----+++++ ++++
 202 ^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^                               ^
 203     universal root       stored here in                                event
 204                          slot directory                                number
 205
 206 Images
 207 ======
 208 /some/path/in/our/system/this/measurement/blah/images/front77.pictures
 209 /some/path/in/our/system/this/measurement/blah/images/front78.pictures
 210                                           ---- ++++++         ++++++++
 211 ^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^             ^^^^^^^^^^^^^^^^
 212     universal root       stored here in               stored file name
 213                          slot directory
 214
 215 ++++ means constant
 216 ---- means unimportant
 217
 218 TODO: /images/ part not currently enforced.")
 219    (cartesian-system
 220     :initarg :cartesian-system
 221     :col-type text
 222     :documentation
 223     "Definition (as a Proj.4 string) of the coordinate system the recorded standard deviations are in."))
 224   (:metaclass dao-class)
 225   (:keys measurement-id)
 226   (:documentation "A measurement comprises .pictures files and one set of GPS event log files in a dedicated directory."))
 227
 228 (deftable sys-measurement
 229   (:create-sequence 'sys-measurement-id-seq)
 230   (!dao-def)
 231   (!index 'measurement-id)
 232   (!foreign 'sys-acquisition-project 'acquisition-project-id
 233             :on-delete :cascade :on-update :cascade))
 234
 235 (defclass sys-presentation ()
 236   ((presentation-project-id
 237     :initarg :presentation-project-id
 238     :col-type integer)
 239    (measurement-id
 240     :initarg :measurement-id
 241     :col-type integer))
 242   (:metaclass dao-class)
 243   (:keys presentation-project-id measurement-id)
 244   (:documentation "Tell us which measurements belong to which presentation project(s)."))
 245
 246 (deftable sys-presentation
 247   (!dao-def)
 248   (!index 'measurement-id)
 249   (!foreign 'sys-presentation-project 'presentation-project-id
 250             :on-delete :cascade :on-update :cascade)
 251   (!foreign 'sys-measurement 'measurement-id
 252             :on-delete :cascade :on-update :cascade))
 253
 254 (defclass sys-camera-hardware ()
 255   ((camera-hardware-id
 256     :reader camera-hardware-id
 257     :col-type integer
 258     :col-default (:nextval 'sys-camera-hardware-id-seq))
 259    (sensor-width-pix
 260     :col-type integer)
 261    (sensor-height-pix
 262     :col-type integer)
 263    (pix-size
 264     :col-type double-float)
 265    (channels
 266     :col-type integer)
 267    (pix-depth
 268     :col-type integer)
 269    (color-raiser
 270     :col-type float[]
 271     :documentation "Array of multipliers for red, green, blue.")
 272    (bayer-pattern
 273     :col-type integer[]
 274     :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.")
 275    (serial-number
 276     :col-type text)
 277    (description
 278     :col-type text
 279     :description "Camera type, manufacturer, etc."))
 280   (:metaclass dao-class)
 281   (:keys camera-hardware-id))
 282
 283 (deftable sys-camera-hardware
 284   (:create-sequence 'sys-camera-hardware-id-seq)
 285   (!dao-def)
 286   (!index 'camera-hardware-id))
 287
 288 (defclass sys-lens ()
 289   ((lens-id
 290     :reader lens-id
 291     :col-type integer
 292     :col-default (:nextval 'sys-lens-id-seq))
 293    (c
 294     :col-type double-float
 295     :documentation "Focal length.  Only for human consumption.")
 296    (serial-number
 297     :col-type text)
 298    (description
 299     :col-type text
 300     :documentation "Lens type, manufacturer, etc."))
 301   (:metaclass dao-class)
 302   (:keys lens-id))
 303
 304 (deftable sys-lens
 305   (:create-sequence 'sys-lens-id-seq)
 306   (!dao-def))
 307
 308 (defclass sys-generic-device ()
 309   ((generic-device-id
 310     :reader generic-device-id
 311     :col-type integer
 312     :col-default (:nextval 'sys-generic-device-id-seq))
 313    (camera-hardware-id
 314     :initarg :camera-hardware-id
 315     :col-type (or db-null integer))
 316    (lens-id
 317     :initarg :lens-id
 318     :col-type (or db-null integer))
 319    (scanner-id
 320     :initarg :scanner-id
 321     :col-type (or db-null integer)
 322     :documentation "Scanners yet to be defined."))
 323   (:metaclass dao-class)
 324   (:keys generic-device-id)
 325   (:documentation "A row should describe either a camera with a lens, or a laser scanner."))
 326
 327 (deftable sys-generic-device
 328   (:create-sequence 'sys-generic-device-id-seq)
 329   (!dao-def)
 330   (!index 'generic-device-id)
 331   (!index 'camera-hardware-id)
 332   (!foreign 'sys-camera-hardware 'camera-hardware-id
 333             :on-delete :restrict :on-update :restrict)
 334   (!foreign 'sys-lens 'lens-id :on-delete :restrict :on-update :restrict)
 335   ;;;; Once we have a sys-scanner table:
 336   ;;(!foreign 'sys-scanner 'scanner-id :on-delete :restrict :on-update :restrict)
 337   )
 338
 339 (defclass sys-device-stage-of-life ()
 340   ((device-stage-of-life-id
 341     :reader device-stage-of-life-id
 342     :col-type integer
 343     :col-default (:nextval 'sys-device-stage-of-life-seq))
 344    (recorded-device-id
 345     :col-type text
 346     :documentation "Must be stored next to each data record.  Example: in a .pictures file, this is the value of `cam=´.")
 347    (event-number
 348     :reader event-number
 349     :col-type text
 350     :documentation "Identifier for the GPS event that triggers this device.  Must correspond to the N the GPS file name: ...eventN.txt.")
 351    (generic-device-id
 352     :col-type integer)
 353    (vehicle-name
 354     :col-type text)
 355    (casing-name
 356     :col-type text
 357     :documentation "Something like `upper rear left´ or maybe `1.2.1´")
 358    (computer-name
 359     :col-type text
 360     :documentation "Computer (or or other recording device) this device is connected to.")
 361    (computer-interface-name
 362     :col-type text
 363     :documentation "Things like `eth0´, `COM1´ etc.")
 364    (mounting-date
 365     :col-type :timestamp-with-time-zone)
 366    (unmounting-date
 367     :col-type (or db-null :timestamp-with-time-zone)
 368     :documentation "Date and time when this device was unmounted or altered in other ways that may render the current calibration invalid."))
 369   (:metaclass dao-class)
 370   (:keys device-stage-of-life-id)
 371   (: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."))
 372
 373 (deftable sys-device-stage-of-life
 374   (:create-sequence 'sys-device-stage-of-life-seq)
 375   (!dao-def)
 376   (!index 'device-stage-of-life-id)
 377   (!index 'recorded-device-id)
 378   (!index 'mounting-date)
 379   (!index 'unmounting-date)
 380   (!foreign 'sys-generic-device 'generic-device-id
 381             :on-delete :restrict :on-update :restrict))
 382
 383 (defclass sys-camera-calibration ()
 384   ((device-stage-of-life-id
 385     :reader device-stage-of-life-id
 386     :col-type integer
 387     :documentation "This tells us what hardware this calibration is for.")
 388    (date
 389     :reader date
 390     :col-type :timestamp-with-time-zone)
 391    (person
 392     :col-type text)
 393    (main-description
 394     :col-type text
 395     :documentation "Regarding this entire set of calibration data.  Note the special-purpose description fields inner-orientation-description, outer-orientation-description, boresight-description.")
 396    (usable
 397     :col-type boolean
 398     :documentation "If false: just display images, don't perform photogrammetric calculations.")
 399    (debug
 400     :col-type boolean
 401     :documentation "If true: not for production use; may be altered or deleted at any time.")
 402    (photogrammetry-version
 403     :col-type text
 404     :documentation "Software version used to create this data.")
 405    (mounting-angle
 406     :col-type integer
 407     :documentation "Head up = 0; right ear up = 90; left ear up = -90; head down = 180.")
 408    (inner-orientation-description
 409     :col-type text
 410     :documentation "Comments regarding inner orientation calibration.")
 411    (c
 412     :col-type double-float
 413     :documentation "Inner orientation: focal length.")
 414    (xh
 415     :col-type double-float
 416     :documentation "Inner orientation: principal point displacement.")
 417    (yh
 418     :col-type double-float
 419     :documentation "Inner orientation: principal point displacement.")
 420    (a1
 421     :col-type double-float
 422     :documentation "Inner orientation: radial distortion.")
 423    (a2
 424     :col-type double-float
 425     :documentation "Inner orientation: radial distortion.")
 426    (a3
 427     :col-type double-float
 428     :documentation "Inner orientation: radial distortion.")
 429    (b1
 430     :col-type double-float
 431     :documentation "Inner orientation: asymmetric and tangential distortion.")
 432    (b2
 433     :col-type double-float
 434     :documentation "Inner orientation: asymmetric and tangential distortion.")
 435    (c1
 436     :col-type double-float
 437     :documentation "Inner orientation: affinity and shear distortion.")
 438    (c2
 439     :col-type double-float
 440     :documentation "Inner orientation: affinity and shear distortion.")
 441    (r0
 442     :col-type double-float
 443     :documentation "Inner orientation.")
 444    (outer-orientation-description
 445     :col-type text
 446     :documentation "Comments regarding outer orientation calibration.")
 447    (dx
 448     :col-type double-float
 449     :documentation "Outer orientation; in metres.")
 450    (dy
 451     :col-type double-float
 452     :documentation "Outer orientation; in metres.")
 453    (dz
 454     :col-type double-float
 455     :documentation "Outer orientation; in metres.")
 456    (omega
 457     :col-type double-float
 458     :documentation "Outer orientation.")
 459    (phi
 460     :col-type double-float
 461     :documentation "Outer orientation.")
 462    (kappa
 463     :col-type double-float
 464     :documentation "Outer orientation.")
 465    (boresight-description
 466     :col-type text
 467     :documentation "Comments regarding boresight alignment calibration.")
 468    (b-dx
 469     :col-type double-float
 470     :documentation "Boresight alignment.")
 471    (b-dy
 472     :col-type double-float
 473     :documentation "Boresight alignment.")
 474    (b-dz
 475     :col-type double-float
 476     :documentation "Boresight alignment.")
 477    (b-ddx
 478     :col-type double-float
 479     :documentation "Boresight alignment.")
 480    (b-ddy
 481     :col-type double-float
 482     :Documentation "Boresight alignment.")
 483    (b-ddz
 484     :col-type double-float
 485     :documentation "Boresight alignment.")
 486    (b-rotx
 487     :col-type double-float
 488     :documentation "Boresight alignment.")
 489    (b-roty
 490     :col-type double-float
 491     :documentation "Boresight alignment.")
 492    (b-rotz
 493     :col-type double-float
 494     :documentation "Boresight alignment.")
 495    (b-drotx
 496     :col-type double-float
 497     :documentation "Boresight alignment.")
 498    (b-droty
 499     :col-type double-float
 500     :documentation "Boresight alignment.")
 501    (b-drotz
 502     :col-type double-float
 503     :documentation "Boresight alignment.")
 504    (nx
 505     :col-type double-float
 506     :documentation "Component of unit vector of vehicle ground plane.")
 507    (ny
 508     :col-type double-float
 509     :documentation "Component of unit vector of vehicle ground plane.")
 510    (nz
 511     :col-type double-float
 512     :documentation "Component of unit vector of vehicle ground plane.")
 513    (d
 514     :col-type double-float
 515     :documentation "Distance of vehicle ground plane."))
 516   (:metaclass dao-class)
 517   (:keys device-stage-of-life-id date)
 518   (:documentation "Camera calibration parameters."))
 519
 520 (deftable sys-camera-calibration
 521   (!dao-def)
 522   (!index 'device-stage-of-life-id)
 523   (!index 'date)
 524   (!foreign 'sys-device-stage-of-life 'device-stage-of-life-id
 525             :on-delete :restrict :on-update :restrict))
 526
 527 (defun phoros-db-major-version ()
 528   "Get the version number of the database structure we are currently
 529 connected to.  It is supposed to be equal to the :major part of
 530 phoros-version."
 531   (query
 532    (:select 'last-value :from 'sys-phoros-major-version)
 533    :single!))
 534
 535 (defun (setf phoros-db-major-version) (major-version)
 536   "Set the version number of the database structure we are currently
 537 connected to. This can only be done once per database."
 538   (execute
 539    (:create-sequence 'sys-phoros-major-version
 540                      :min-value -1
 541                      :max-value major-version
 542                      :start major-version))
 543   (phoros-db-major-version))
 544
 545 (defun assert-phoros-db-major-version ()
 546   "Check if phoros version and version of the database we are
 547 connected to match."
 548   (assert (= (phoros-db-major-version) (phoros-version :major t)) ()
 549           "Can't use a Phoros database structure of version ~D.  ~
 550            It should be version ~D.  ~
 551            Either create a new database structure using this version of ~
 552            Phoros, or use Phoros version ~2:*~D.x.x."
 553           (phoros-db-major-version) (phoros-version :major t)))
 554
 555 (defun create-sys-tables ()
 556   "Create in current database a set of sys-* tables, i.e. tables that
 557 are used by all projects.  The database should probably be empty."
 558   (setf (phoros-db-major-version) (phoros-version :major t))
 559   (create-table 'sys-user)
 560   (create-table 'sys-acquisition-project)
 561   (create-table 'sys-presentation-project)
 562   (create-table 'sys-user-role)
 563   (create-table 'sys-measurement)
 564   (create-table 'sys-presentation)
 565   (create-table 'sys-camera-hardware)
 566   (create-table 'sys-lens)
 567   (create-table 'sys-generic-device)
 568   (create-table 'sys-device-stage-of-life)
 569   (create-table 'sys-camera-calibration)
 570   (create-plpgsql-helpers))
 571
 572 (defun create-plpgsql-helpers ()
 573   "Create in current database a few SQL types and functions."
 574   (execute
 575    (format nil "
 576 CREATE OR REPLACE
 577 FUNCTION bendedness
 578          (point1 GEOMETRY, point2 GEOMETRY, point3 GEOMETRY)
 579 RETURNS DOUBLE PRECISION AS $$
 580 -- Phoros version ~A
 581 BEGIN
 582   RETURN abs(st_azimuth(point2, point3) - st_azimuth(point1, point2));
 583 END;
 584 $$ LANGUAGE plpgsql;"
 585            (phoros-version)))
 586   (execute
 587    "DROP TYPE IF EXISTS point_bag;")
 588   (execute
 589    "CREATE TYPE point_bag AS (id int, coordinates GEOMETRY);"))
 590
 591 (defun !!index (table field &key (index-type :btree))
 592   (format nil "CREATE INDEX ~0@*~A_~1@*~A_index ON ~0@*~A USING ~2@*~A (~1@*~A)"
 593           (s-sql:to-sql-name table)
 594           (s-sql:to-sql-name field)
 595           (s-sql:to-sql-name index-type)))
 596
 597 (defclass point-template ()
 598   (;; We need a slot point-id which is defined in our subclasses.
 599    (random
 600     :col-type integer
 601     :initform (random (expt 2 31))
 602     :documentation "Used for quickly getting an evenly distributed sample of all points.")
 603    (measurement-id
 604     :writer (setf measurement-id)
 605     :col-type integer)
 606    (event-number
 607     :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.")
 608    (gps-time
 609     :reader gps-time
 610     :documentation "UTC calculated from GPS week time.")
 611    (trigger-time
 612     :writer (setf trigger-time)
 613     :col-type double-precision
 614     :documentation "Time in seconds from 1900.  Values before 1980-01-06T00:00:00Z are considered invalid.")
 615    (roll
 616     :col-type double-precision)
 617    (pitch
 618     :col-type double-precision)
 619    (heading
 620     :col-type double-precision)
 621    (east-velocity
 622     :col-type double-precision)
 623    (north-velocity
 624     :col-type double-precision)
 625    (up-velocity
 626     :col-type double-precision)
 627    (east-sd
 628     :col-type double-precision)
 629    (north-sd
 630     :col-type double-precision)
 631    (height-sd
 632     :col-type double-precision)
 633    (roll-sd
 634     :col-type double-precision)
 635    (pitch-sd
 636     :col-type double-precision)
 637    (heading-sd
 638     :col-type double-precision)
 639    (longitude
 640     :reader longitude
 641     :documentation "Same content as in slot coordinates.")
 642    (latitude
 643     :reader latitude
 644     :documentation "Same content as in slot coordinates.")
 645    (ellipsoid-height
 646     :reader ellipsoid-height
 647     :documentation "Same content as in slot coordinates.")
 648    (coordinates
 649     :col-type (or db-null geometry)
 650     :documentation "Geographic coordinates.")
 651    (easting
 652     :reader easting
 653     :documentation "In the same coordinate system as the standard deviations.")
 654    (northing
 655     :reader northing
 656     :documentation "In the same coordinate system as the standard deviations.")
 657    (cartesian-height
 658     :reader cartesian-height
 659     :documentation "In the same coordinate system as the standard deviations."))
 660   (:metaclass dao-class)
 661   (:keys point-id)
 662   (: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."))
 663
 664 (defclass image-template ()
 665   ((measurement-id
 666     :writer (setf measurement-id)
 667     :col-type integer
 668     :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.")
 669    (filename
 670     :reader filename
 671     :initarg :filename
 672     :col-type text
 673     :documentation "Name without any directory components.")
 674    (byte-position
 675     :reader image-byte-position
 676     :initarg :byte-position
 677     :col-type integer
 678     :documentation "Start of image in .pictures file named by slot filename.")
 679    (point-id
 680     :accessor point-id
 681     :col-type integer)
 682    (recorded-device-id
 683     :initarg :recorded-device-id
 684     :reader recorded-device-id
 685     :col-type text
 686     :documentation "As found in .pictures file, header tag `cam=´.")
 687    (footprint
 688     :initarg :footprint
 689     :col-type (or db-null geometry)
 690     :documentation "Polygon on the ground describing the approximate area covered by this image.")
 691    (footprint-device-stage-of-life-id
 692     :initarg :footprint-device-stage-of-life-id
 693     :col-type (or db-null integer)
 694     :documentation "device-stage-of-life denoting the set of calibration data the footprint of this record has been calculated with.")
 695    (gain
 696     :initarg :gain
 697     :col-type double-precision
 698     :documentation "Camera parameter. TODO: needs a decent definition")
 699    (shutter
 700     :initarg :shutter
 701     :col-type double-precision
 702     :documentation "Camera parameter. TODO: needs a decent definition")
 703    (trigger-time
 704     :initarg :trigger-time
 705     :accessor trigger-time
 706     :documentation "Time in seconds from 1900-01-01.")
 707    (fake-trigger-time-p
 708     :accessor fake-trigger-time-p
 709     :initform nil
 710     :documentation "T if trigger-time has been reconstructed from adjacent data.")
 711    (camera-timestamp
 712     :initarg :camera-timestamp
 713     :reader camera-timestamp
 714     :documentation "Some camera clocktick count starting at an unknown origin."))
 715   (:metaclass dao-class)
 716   (:keys measurement-id filename byte-position)
 717   (:documentation "One row per image, originating from a .pictures file."))
 718
 719 (defclass user-point-template ()
 720   (;; We need a slot user-point-id which is defined in our subclasses.
 721    (user-id
 722     :initarg :user-id
 723     :col-type (or db-null ;when store-user-points is fed an unknown user-name
 724                   integer)
 725     :documentation "User who stored this point.")
 726    (attribute
 727     :initarg :attribute
 728     :col-type text
 729     :documentation "Class of this user point.")
 730    (description
 731     :initarg :description
 732     :col-type text
 733     :documentation "User comment regarding this point.")
 734    (numeric-description
 735     :initarg :numeric-description
 736     :col-type text
 737     :documentation "User-generated point id regarding this point.")
 738    (creation-date
 739     :col-type :timestamp-with-time-zone
 740     :documentation "Creation time of this point.")
 741    (coordinates
 742     :col-type (or db-null geometry)
 743     :documentation "Geographic coordinates.")
 744    (stdx-global
 745     :initarg :stdx-global
 746     :col-type double-precision
 747     :documentation "Component of standard deviation, in metres.")
 748    (stdy-global
 749     :initarg :stdy-global
 750     :col-type double-precision
 751     :documentation "Component of standard deviation, in metres.")
 752    (stdz-global
 753     :initarg :stdz-global
 754     :col-type double-precision
 755     :documentation "Component of standard deviation, in metres.")
 756    (input-size
 757     :initarg :input-size
 758     :col-type integer
 759     :documentation "Number of points (from different images) used for calculation.")
 760    (aux-numeric
 761     :col-type (or db-null numeric[])
 762     :documentation "Arbitrary numeric values from auxiliary point table.")
 763    (aux-text
 764     :col-type (or db-null text[])
 765     :documentation "Arbitrary text values from auxiliary point table."))
 766   (:metaclass dao-class)
 767   (:keys user-point-id)
 768   (:documentation "Points defined by users."))
 769
 770 (defclass point-data (point-template)
 771   ((point-id
 772     :accessor point-id
 773     :initform nil
 774     :col-type integer
 775     :col-default nil)                   ;to be redefined
 776    point-id-sequence-name)              ;to be redefined
 777   (:metaclass dao-class)
 778   (:table-name nil))                    ;to be redefined
 779
 780 (defclass image-data (image-template)
 781   ()
 782   (:metaclass dao-class)
 783   (:table-name nil))                    ;to be redefined
 784
 785 (defclass user-point-data (user-point-template)
 786   ((user-point-id
 787     :accessor user-point-id
 788     :initform nil
 789     :col-type integer
 790     :col-default nil)                   ;to be redefined
 791    user-point-id-sequence-name)         ;to be redefined)
 792   (:metaclass dao-class)
 793   (:table-name nil))                    ;to be redefined
 794
 795 (let ((table-prefix "dat-"))
 796   (defun point-data-table-name (common-table-name)
 797     (make-symbol (format nil "~A~A-point"
 798                          table-prefix common-table-name)))
 799
 800   (defun image-data-table-name (common-table-name)
 801     (make-symbol (format nil "~A~A-image"
 802                          table-prefix common-table-name)))
 803
 804   (defun point-id-seq-name (common-table-name)
 805     (make-symbol (format nil "~A~A-point-id-seq"
 806                          table-prefix common-table-name)))
 807
 808   (defun aggregate-view-name (common-table-name)
 809     (make-symbol (format nil "~A~A-aggregate"
 810                          table-prefix common-table-name)))
 811
 812   (defun aggregate-view-update-rule-name (common-table-name)
 813     (make-symbol (format nil "~A~A-aggregate-update"
 814                          table-prefix common-table-name))))
 815
 816 (let ((table-prefix "usr-"))
 817   (defun user-point-table-name (presentation-project-name)
 818     (make-symbol (format nil "~A~A-point"
 819                          table-prefix presentation-project-name)))
 820
 821   (defun user-point-id-seq-name (presentation-project-name)
 822     (make-symbol (format nil "~A~A-point-id-seq"
 823                          table-prefix presentation-project-name)))
 824
 825   (defun user-line-table-name (presentation-project-name)
 826     (make-symbol (format nil "~A~A-line"
 827                          table-prefix presentation-project-name))))
 828
 829 (let ((table-prefix "phoros-"))
 830   ;; This stuff may reside in a foreign database so we show explicitly
 831   ;; what it belongs to.
 832   (defun aux-point-view-name (presentation-project-name)
 833     (make-symbol (format nil "~A~A-aux-point"
 834                          table-prefix presentation-project-name)))
 835
 836   (defun thread-aux-points-function-name (presentation-project-name)
 837     (make-symbol (format nil "~A~A-thread-aux-points"
 838                           table-prefix presentation-project-name))))
 839
 840 (defun create-data-table-definitions (common-table-name)
 841   "Define or redefine a bunch of dao-classes which can hold measuring
 842 data and which are connected to database tables named
 843 common-table-name plus type-specific prefix and suffix."
 844   (let ((image-data-table-name (image-data-table-name common-table-name))
 845         (point-data-table-name (point-data-table-name common-table-name))
 846         (point-id-sequence-name (point-id-seq-name common-table-name)))
 847     (eval
 848      `(defclass point-data (point-template)
 849         ((point-id
 850           :accessor point-id
 851           :initform nil
 852           :col-type integer
 853           :col-default (:nextval ,point-id-sequence-name)) ; redefinition
 854          (point-id-sequence-name
 855           :initform ,(string point-id-sequence-name) ; redefinition
 856           :reader point-id-sequence-name
 857           :allocation :class))
 858         (:metaclass dao-class)
 859         (:table-name ,point-data-table-name))) ;redefinition
 860     (deftable point-data
 861       (:create-sequence point-id-sequence-name)
 862       (!dao-def)
 863       (!!index point-data-table-name 'random)
 864       (!!index point-data-table-name 'measurement-id)
 865       (!!index point-data-table-name 'trigger-time)
 866       (!!index point-data-table-name 'coordinates :index-type :gist)
 867       (!!index point-data-table-name 'point-id)
 868       ;; The following let shouldn't be necessary. (Wart In !foreign.)
 869       (let ((*table-symbol* point-data-table-name)
 870             (*table-name*  (s-sql:to-sql-name point-data-table-name)))
 871         (!foreign 'sys-measurement 'measurement-id
 872                   :on-delete :cascade :on-update :cascade)))
 873     (eval
 874      `(defclass image-data (image-template)
 875         ()
 876         (:metaclass dao-class)
 877         (:table-name ,image-data-table-name))) ; redefintion
 878     (deftable image-data
 879       (!dao-def)
 880       (!!index image-data-table-name 'measurement-id)
 881       (!!index image-data-table-name 'recorded-device-id)
 882       (!!index image-data-table-name 'point-id)
 883       ;; (!!index image-data-table-name 'gain)
 884       ;; (!!index image-data-table-name 'shutter)
 885       (!!index image-data-table-name 'footprint :index-type :gist)
 886       ;; The following let shouldn't be necessary. (Wart in !foreign.)
 887       (let ((*table-symbol* image-data-table-name)
 888             (*table-name*  (s-sql:to-sql-name image-data-table-name)))
 889         (!foreign point-data-table-name 'point-id
 890                   :on-delete :cascade :on-update :cascade)
 891         (!foreign 'sys-measurement 'measurement-id
 892                   :on-delete :cascade :on-update :cascade)))))
 893
 894 (defun create-user-table-definition (presentation-project-name)
 895   "Define or redefine a dao-class which can hold user points and which
 896 is connected to a database table named presentation-project-name plus
 897 type-specific prefix and suffix."
 898   (let ((user-point-table-name (user-point-table-name presentation-project-name))
 899         (user-point-id-sequence-name (user-point-id-seq-name presentation-project-name)))
 900     (eval
 901      `(defclass user-point (user-point-template)
 902         ((user-point-id
 903           :accessor point-id
 904           :initform nil
 905           :col-type integer
 906           :col-default (:nextval ,user-point-id-sequence-name))) ; redefinition
 907         (:metaclass dao-class)
 908         (:table-name ,user-point-table-name))) ;redefinition
 909     (deftable user-point
 910       (:create-sequence user-point-id-sequence-name)
 911       (!dao-def)
 912       (!!index user-point-table-name 'coordinates :index-type :gist))))
 913
 914 (defun create-aggregate-view (common-table-name)
 915   "Create a view of a set of measuring and calibration data
 916 belonging to images."
 917   (let ((image-data-table-name (image-data-table-name common-table-name))
 918         (point-data-table-name (point-data-table-name common-table-name))
 919         (aggregate-view-name (aggregate-view-name common-table-name))
 920         (aggregate-view-update-rule-name (aggregate-view-update-rule-name
 921                                           common-table-name)))
 922     (eval
 923      `(execute
 924        (:create-view
 925         ,aggregate-view-name
 926         (:select
 927          'sys-device-stage-of-life.recorded-device-id      ;debug
 928          'sys-device-stage-of-life.device-stage-of-life-id ;debug
 929          'sys-device-stage-of-life.generic-device-id       ;debug
 930          'random
 931          'presentation-project-id
 932          'directory
 933          (:dot ',image-data-table-name 'measurement-id)
 934          'filename 'byte-position
 935          (:dot ',point-data-table-name 'point-id)
 936          'footprint 'footprint-device-stage-of-life-id
 937          'trigger-time
 938          'coordinates                   ;the search target
 939          (:as (:st_x (:st_transform 'coordinates *standard-coordinates*))
 940               'longitude)
 941          (:as (:st_y (:st_transform 'coordinates *standard-coordinates*))
 942               'latitude)
 943          (:as (:st_z (:st_transform 'coordinates *standard-coordinates*))
 944               'ellipsoid-height)
 945          'cartesian-system
 946          'east-sd 'north-sd 'height-sd
 947          'roll 'pitch 'heading 'roll-sd 'pitch-sd 'heading-sd
 948          'usable
 949          'sensor-width-pix 'sensor-height-pix 'pix-size
 950          'bayer-pattern 'color-raiser
 951          'mounting-angle
 952          'dx 'dy 'dz 'omega 'phi 'kappa
 953          'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
 954          'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
 955          'b-ddx 'b-ddy 'b-ddz 'b-drotx 'b-droty 'b-drotz
 956          'nx 'ny 'nz 'd
 957          :from
 958          'sys-measurement
 959          'sys-presentation
 960          ',point-data-table-name ',image-data-table-name
 961          'sys-device-stage-of-life 'sys-generic-device 'sys-camera-hardware
 962          'sys-camera-calibration
 963          :where
 964          (:and
 965           (:= (:dot ',image-data-table-name 'measurement-id)
 966               'sys-presentation.measurement-id)
 967           (:= 'sys-presentation.measurement-id
 968               'sys-measurement.measurement-id)
 969           (:= (:dot ',point-data-table-name 'point-id)
 970               (:dot ',image-data-table-name 'point-id))
 971           (:= (:dot ',image-data-table-name 'recorded-device-id)
 972               'sys-device-stage-of-life.recorded-device-id)
 973           (:= 'sys-generic-device.generic-device-id
 974               'sys-device-stage-of-life.generic-device-id)
 975           (:= 'sys-camera-hardware.camera-hardware-id
 976               'sys-generic-device.camera-hardware-id)
 977           (:= 'sys-device-stage-of-life.device-stage-of-life-id
 978               'sys-camera-calibration.device-stage-of-life-id)
 979           (:= 'sys-device-stage-of-life.device-stage-of-life-id
 980               (:limit
 981                (:order-by
 982                 (:select 'sys-camera-calibration.device-stage-of-life-id
 983                          :from 'sys-camera-calibration
 984                          :where
 985                          (:= 'sys-device-stage-of-life.device-stage-of-life-id
 986                              'sys-camera-calibration.device-stage-of-life-id))
 987                 (:desc 'date))
 988                1))
 989           (:<= (:extract :epoch 'sys-device-stage-of-life.mounting-date)
 990                (:- (:dot ',point-data-table-name 'trigger-time)
 991                    *unix-epoch*))
 992           (:or (:is-null 'sys-device-stage-of-life.unmounting-date)
 993                (:>= (:extract :epoch 'sys-device-stage-of-life.unmounting-date)
 994                     (:- (:dot ',point-data-table-name 'trigger-time)
 995                         *unix-epoch*))))))))
 996     (execute
 997      (format
 998       nil
 999       "CREATE OR REPLACE RULE ~A ~
1000          AS ON UPDATE TO ~A DO INSTEAD ~
1001            UPDATE ~A ~
1002              SET footprint = NEW.footprint, ~
1003              footprint_device_stage_of_life_id = OLD.device_stage_of_life_id
1004              WHERE byte_position = OLD.byte_position ~
1005                AND filename = OLD.filename ~
1006                AND measurement_id = OLD.measurement_id;"
1007       (s-sql:to-sql-name aggregate-view-update-rule-name)
1008       (s-sql:to-sql-name aggregate-view-name)
1009       (s-sql:to-sql-name image-data-table-name)))))
1010
1011 (defun aux-view-exists-p (presentation-project-name)
1012   "See if there is a view into auxiliary point table that belongs to
1013 presentation-project-name."
1014   (view-exists-p (aux-point-view-name presentation-project-name)))
1015
1016 (defun delete-aux-view (presentation-project-name)
1017   "Delete the view into auxiliary point table that belongs to
1018 presentation-project-name."
1019   (execute (format nil "DROP VIEW ~A CASCADE;"
1020                    (s-sql:to-sql-name (aux-point-view-name
1021                                        presentation-project-name))))
1022   (execute
1023    (format nil "DROP FUNCTION IF EXISTS ~
1024                 ~A(GEOMETRY, DOUBLE PRECISION, INT, DOUBLE PRECISION);"
1025            (s-sql:to-sql-name (thread-aux-points-function-name
1026                                presentation-project-name)))))
1027
1028 (defun* create-aux-view (presentation-project-name
1029                         &key (coordinates-column :the-geom)
1030                         numeric-columns text-columns
1031                         &mandatory-key aux-table)
1032   "Create a view into aux-table and an SQL function for threading
1033 aux-points into a linestring.  coordinates-column goes into column
1034 coordinates, numeric-columns and text-columns go into arrays in
1035 aux-numeric and aux-text respectively.
1036
1037 aux-table should have an index like so:
1038
1039 CREATE INDEX idx_<aux-table>_the_geom
1040   ON <aux-table>
1041   USING gist (the_geom);
1042
1043 VACUUM FULL ANALYZE <aux-table> (the_geom);"
1044   (create-plpgsql-helpers)
1045   (let ((aux-point-view-name
1046          (aux-point-view-name presentation-project-name))
1047         (thread-aux-points-function-name
1048          (thread-aux-points-function-name presentation-project-name)))
1049     (execute (format nil "
1050 CREATE VIEW ~A
1051 AS (SELECT ~A AS coordinates,
1052     ~:[NULL~;ARRAY[~:*~{~A~#^, ~}]~] AS aux_numeric,
1053     ~:[NULL~;ARRAY[~:*~{~A~#^, ~}]~] AS aux_text
1054     FROM ~A)"
1055                      (s-sql:to-sql-name aux-point-view-name)
1056                      coordinates-column
1057                      (mapcar #'s-sql:to-sql-name numeric-columns)
1058                      (mapcar #'s-sql:to-sql-name text-columns)
1059                      (s-sql:to-sql-name aux-table)))
1060     (execute (format nil "~
1061 CREATE OR REPLACE FUNCTION ~0@*~A
1062   (point GEOMETRY, sample_radius DOUBLE PRECISION, sample_size INT,
1063    step_size DOUBLE PRECISION, old_azimuth DOUBLE PRECISION,
1064    max_bend DOUBLE PRECISION,
1065    OUT threaded_points TEXT,
1066    OUT current_point TEXT,
1067    OUT back_point TEXT, OUT forward_point TEXT,
1068    OUT new_azimuth DOUBLE PRECISION)
1069 AS
1070 $$
1071 -- Phoros version ~2@*~A
1072 DECLARE
1073   point_bag_size INT;
1074   current_point_position DOUBLE PRECISION;
1075   location DOUBLE PRECISION;
1076   line GEOMETRY;
1077   new_point point_bag%ROWTYPE;
1078   tried_point point_bag%ROWTYPE;
1079   previous_point point_bag%ROWTYPE;
1080   starting_point GEOMETRY;
1081   reversal_count INT DEFAULT 0;
1082 BEGIN
1083   -- Muffle warnings about implicitly created stuff:
1084   SET client_min_messages TO ERROR;
1085
1086   starting_point :=
1087     (SELECT coordinates
1088        FROM ~1@*~A
1089        WHERE
1090          coordinates
1091          &&
1092          st_setsrid(st_makebox3d (st_translate (point,
1093                                                 - sample_radius * 5,
1094                                                 - sample_radius * 5, 0),
1095                                   st_translate (point,
1096                                                 sample_radius * 5,
1097                                                 sample_radius * 5, 0)),
1098                     4326)
1099        ORDER BY st_distance(coordinates, point)
1100        LIMIT 1);
1101
1102   CREATE TEMPORARY TABLE point_bag
1103     (id SERIAL primary key, coordinates GEOMETRY)
1104     ON COMMIT DROP;
1105
1106   INSERT INTO point_bag (coordinates)
1107     SELECT coordinates
1108       FROM ~1@*~A
1109
1110       WHERE
1111         coordinates
1112         &&
1113         st_setsrid(st_makebox3d (st_translate (starting_point,
1114                                                - sample_radius,
1115                                                - sample_radius, 0),
1116                                  st_translate (starting_point,
1117                                                sample_radius,
1118                                                sample_radius, 0)),
1119                    4326)
1120         AND st_distance (coordinates, starting_point) < sample_radius
1121       ORDER BY st_distance (coordinates, starting_point)
1122       LIMIT sample_size;
1123
1124   point_bag_size := (SELECT count(*) from point_bag);
1125
1126   -- emergency point_bag:
1127   IF point_bag_size < 5
1128   THEN
1129     DROP TABLE point_bag;
1130     CREATE TEMPORARY TABLE point_bag
1131       (id SERIAL primary key, coordinates GEOMETRY)
1132       ON COMMIT DROP;
1133     INSERT INTO point_bag (coordinates)
1134       SELECT coordinates
1135         FROM ~1@*~A
1136         WHERE
1137           coordinates
1138           &&
1139           st_setsrid(st_makebox3d (st_translate (point,
1140                                                  - sample_radius * 100,
1141                                                  - sample_radius * 100, 0),
1142                                    st_translate (point,
1143                                                  sample_radius * 100,
1144                                                  sample_radius * 100, 0)),
1145                      4326)
1146         ORDER BY st_distance (coordinates, starting_point)
1147         LIMIT 5;
1148     starting_point := (SELECT coordinates FROM point_bag where id = 3);
1149   END IF;
1150
1151   previous_point :=
1152     (SELECT ROW(id, coordinates)
1153        FROM point_bag
1154        ORDER BY st_distance (point_bag.coordinates, starting_point)
1155        LIMIT 1);
1156
1157   DELETE FROM point_bag WHERE id = previous_point.id;
1158
1159   new_point :=
1160     (SELECT ROW(id, coordinates)
1161        FROM point_bag
1162        ORDER BY st_distance (point_bag.coordinates, previous_point.coordinates)
1163        LIMIT 1);
1164
1165   line := st_makeline(previous_point.coordinates,
1166                       new_point.coordinates);
1167
1168   new_azimuth :=
1169     st_azimuth(previous_point.coordinates, new_point.coordinates);
1170
1171   IF abs(new_azimuth - old_azimuth) > radians(90)
1172      AND
1173      abs(new_azimuth - old_azimuth) < radians(270)
1174   THEN
1175     new_azimuth :=
1176       st_azimuth(new_point.coordinates, previous_point.coordinates);
1177     line := st_reverse(line);
1178   END IF;
1179
1180   DELETE FROM point_bag WHERE id = new_point.id;
1181
1182   LOOP
1183     previous_point.coordinates := st_pointn(line,1);
1184
1185     new_point :=
1186       (SELECT ROW(id, coordinates)
1187          FROM point_bag
1188          ORDER BY st_distance (coordinates, previous_point.coordinates)
1189          LIMIT 1);
1190
1191     EXIT WHEN new_point IS NULL;
1192
1193     IF bendedness(st_pointn(line, 2), st_pointn(line, 1),
1194                   new_point.coordinates)
1195        < bendedness(st_pointn(line, st_npoints(line) - 1),
1196                     st_pointn(line, st_npoints(line)), new_point.coordinates)
1197        AND
1198        bendedness(st_pointn(line, 2), st_pointn(line, 1),
1199                    new_point.coordinates)
1200        < max_bend
1201     THEN
1202         line := st_addpoint(line, new_point.coordinates, 0);
1203         DELETE FROM point_bag WHERE id = new_point.id;
1204     END IF;
1205
1206     line := st_reverse(line);
1207
1208     reversal_count := reversal_count + 1 ;
1209
1210     DELETE FROM point_bag WHERE id = tried_point.id;
1211
1212     tried_point := new_point;
1213   END LOOP;
1214
1215   IF mod(reversal_count, 2) = 1
1216   THEN
1217     line := st_reverse(line);
1218   END IF;
1219
1220   current_point_position :=
1221     st_line_locate_point(line, point);
1222
1223   current_point :=
1224     st_astext(st_line_interpolate_point(line, current_point_position));
1225
1226   location := (current_point_position - (step_size / st_length(line)));
1227   IF location < 0 THEN location := 0; END IF;
1228
1229   back_point :=
1230     st_astext(st_line_interpolate_point(line, location));
1231
1232   location := (current_point_position + (step_size / st_length(line)));
1233   IF location > 0 THEN location := 1; END IF;
1234
1235   forward_point :=
1236     st_astext(st_line_interpolate_point(line, location));
1237
1238   threaded_points := st_astext(line);
1239
1240   RETURN;
1241 END;
1242 $$ LANGUAGE plpgsql;"
1243                      (s-sql:to-sql-name thread-aux-points-function-name)
1244                      (s-sql:to-sql-name aux-point-view-name)
1245                      (phoros-version)))))
1246
1247 (defun create-acquisition-project (common-table-name)
1248   "Create in current database a fresh set of canonically named tables.
1249 common-table-name should in most cases resemble the project name and
1250 will be stored in table sys-acquisition-project, field
1251 common-table-name."
1252   (create-data-table-definitions common-table-name)
1253   (handler-case (create-sys-tables) ;Create system tables if necessary.
1254     (cl-postgres-error:syntax-error-or-access-violation () nil))
1255   (assert-phoros-db-major-version)
1256   (when (select-dao 'sys-acquisition-project
1257                     (:= 'common-table-name
1258                         (s-sql:to-sql-name common-table-name)))
1259     (error "There is already a row with a common-table-name of ~A in table ~A."
1260            common-table-name
1261            (s-sql:to-sql-name (dao-table-name 'sys-acquisition-project))))
1262   (create-table 'point-data)
1263   (create-table 'image-data)
1264   (create-aggregate-view common-table-name)
1265   (insert-dao
1266    (make-instance 'sys-acquisition-project
1267                   :common-table-name common-table-name)))
1268
1269 (defun delete-acquisition-project (common-table-name)
1270   "Delete the acquisition project that uses common-table-name.  Return
1271 nil if there wasn't any."
1272   (assert-phoros-db-major-version)
1273   (let ((project
1274          (car (select-dao 'sys-acquisition-project
1275                           (:= 'common-table-name common-table-name)))))
1276     (when project
1277       (delete-dao project)
1278       (execute (:drop-view
1279                 :if-exists (aggregate-view-name common-table-name)))
1280       (execute (:drop-table
1281                 :if-exists (image-data-table-name common-table-name)))
1282       (execute (:drop-table
1283                 :if-exists (point-data-table-name common-table-name)))
1284       (execute (:drop-sequence
1285                 :if-exists (point-id-seq-name common-table-name))))))
1286
1287 (defun delete-measurement (measurement-id)
1288   "Delete measurement with measurement-id if any; return nil if not."
1289   (assert-phoros-db-major-version)
1290   (let ((measurement (get-dao 'sys-measurement measurement-id)))
1291     (when measurement (delete-dao measurement))))
1292
1293 (defun create-presentation-project (project-name)
1294   "Create a fresh presentation project in current database.  Return
1295 dao if one was created, or nil if it existed already."
1296   (assert-phoros-db-major-version)
1297   (unless (get-dao 'sys-presentation-project project-name)
1298     (create-user-table-definition project-name)
1299     (create-table 'user-point)
1300     (create-presentation-project-trigger-function project-name)
1301     (execute (format nil "DROP TRIGGER IF EXISTS ~A ON ~:*~A;"
1302                      (s-sql:to-sql-name (user-point-table-name project-name))))
1303     (execute (format nil "
1304 CREATE TRIGGER ~A
1305   AFTER INSERT OR UPDATE OR DELETE
1306   ON ~:*~A
1307   FOR EACH ROW EXECUTE PROCEDURE ~:*~A();"
1308                      (s-sql:to-sql-name (user-point-table-name project-name))))
1309     (execute (sql-compile
1310               `(:create-table ,(user-line-table-name project-name)
1311                               ((description :type text)
1312                                ;; description would be a nice primary
1313                                ;; key if it wasn't for QGIS which
1314                                ;; needs it numeric
1315                                (id :type serial :primary-key t)
1316                                (line :type geometry)))))
1317     (insert-dao (make-instance 'sys-presentation-project
1318                                :presentation-project-name project-name))))
1319
1320 (defun create-presentation-project-trigger-function
1321     (presentation-project
1322      &optional (plpgsql-body
1323                 (format
1324                  nil "  RAISE NOTICE 'trigger fired: ~A';"
1325                  (s-sql:to-sql-name (user-point-table-name
1326                                      presentation-project))))
1327      &rest plpgsql-body-args)
1328   "(Re)create in current database an SQL trigger function with
1329 plpgsql-body (a format string that uses plpgsql-body-args)."
1330   (execute (format
1331             nil "
1332 CREATE OR REPLACE FUNCTION ~A() RETURNS trigger
1333 AS
1334 $$
1335 BEGIN
1336   ------------------------------------------
1337   -- Define your trigger actions below:
1338   ------------------------------------------
1339 ~?~&~:
1340   ------------------------------------------
1341   -- End of your trigger action definitions.
1342   ------------------------------------------
1343   RETURN NULL;
1344 END;
1345 $$ LANGUAGE plpgsql;"
1346             (s-sql:to-sql-name (user-point-table-name presentation-project))
1347             plpgsql-body
1348             plpgsql-body-args)))
1349
1350 (defun fire-presentation-project-trigger-function (presentation-project)
1351   "Tickle user point table of presentation-project so it fires its
1352 trigger."
1353   (let ((user-point-table (user-point-table-name presentation-project)))
1354     (execute
1355      (:update user-point-table
1356               :set 'user-point-id 'user-point-id
1357               :where (:= 'user-point-id
1358                          (:limit (:select 'user-point-id
1359                                           :from user-point-table) 1))))))
1360
1361 (defun delete-presentation-project (project-name)
1362   "Delete the presentation project project-name.  Return nil if there
1363 wasn't any."
1364   (assert-phoros-db-major-version)
1365   (let ((project (get-dao 'sys-presentation-project project-name)))
1366     (when project
1367       (delete-dao project)
1368       (execute
1369        (:drop-table :if-exists (user-point-table-name project-name)))
1370       (execute
1371        (:drop-sequence :if-exists (user-point-id-seq-name project-name)))
1372       (execute
1373        (:drop-table :if-exists (user-line-table-name project-name))))))
1374
1375 (defun* create-user (name &key
1376                           presentation-projects
1377                           &mandatory-key
1378                           user-password
1379                           user-full-name
1380                           user-role)
1381   "Create a fresh user entry or update an existing one with matching
1382 name.  Assign it presentation-projects, deleting any previously
1383 existing assignments."
1384   (assert-phoros-db-major-version)
1385   (assert (or (string-equal "read" user-role)
1386               (string-equal "write" user-role)
1387               (string-equal "admin" user-role))
1388           (user-role)
1389           "~A is not a valid user-role." user-role)
1390   (let ((user (or (car (select-dao 'sys-user (:= 'user-name name)))
1391                   (make-instance 'sys-user :user-name name)))
1392         fresh-user-p)
1393     (setf (user-password user) user-password
1394           (user-full-name user) user-full-name)
1395     (setf fresh-user-p (save-dao user))
1396     (mapcar #'delete-dao (select-dao 'sys-user-role
1397                                      (:= 'user-id (user-id user))))
1398     (dolist (presentation-project-name presentation-projects)
1399       (let ((presentation-project
1400              (get-dao 'sys-presentation-project presentation-project-name)))
1401         (if presentation-project
1402             (insert-dao
1403              (make-instance
1404               'sys-user-role
1405               :user-id (user-id user)
1406               :presentation-project-id
1407               (presentation-project-id presentation-project)
1408               :user-role (string-downcase user-role))) ;TODO: we should be able to set role per presentation-project.
1409             (warn
1410              "There is no presentation project ~A" presentation-project-name))))
1411     fresh-user-p))
1412
1413 (defun delete-user (user-name)
1414   "Delete user user-name if any; return nil if not."
1415   (assert-phoros-db-major-version)
1416   (let ((user (car (select-dao 'sys-user (:= 'user-name user-name)))))
1417     (when user (delete-dao user))))
1418
1419 (defun add-to-presentation-project (presentation-project-name
1420                                     &key measurement-ids acquisition-project)
1421   "Add to presentation project presentation-project-name either a list
1422 of measurements (with measurement-id) or all measurements currently in
1423 acquisition-project (denoted by its common-table-name)."
1424   (assert-phoros-db-major-version)
1425   (let* ((presentation-project
1426           (car (select-dao 'sys-presentation-project
1427                            (:= 'presentation-project-name
1428                                presentation-project-name))))
1429          (presentation-project-id
1430           (presentation-project-id presentation-project)))
1431     (flet ((add-measurement (measurement-id)
1432              "Add one measurement to the given presentation-project."
1433              (unless (get-dao 'sys-presentation
1434                               presentation-project-id
1435                               measurement-id)
1436                (insert-dao
1437                 (make-instance 'sys-presentation
1438                                :presentation-project-id presentation-project-id
1439                                :measurement-id measurement-id)))))
1440       (cond (measurement-ids (mapc #'add-measurement measurement-ids))
1441             (acquisition-project
1442              (dolist
1443                  (measurement-id
1444                    (query
1445                     (:select
1446                      'measurement-id
1447                      :from 'sys-measurement 'sys-acquisition-project
1448                      :where (:and
1449                              (:= 'sys-acquisition-project.common-table-name
1450                                  acquisition-project)
1451                              (:= 'sys-measurement.acquisition-project-id
1452                                  'sys-acquisition-project.acquisition-project-id)))
1453                     :column))
1454                (add-measurement measurement-id)))
1455             (t (error
1456                 "Don't know what to add.  ~
1457                  Need either measurement-id or acquisition-project."))))
1458     (let* ((common-table-names
1459             (common-table-names presentation-project-id))
1460            (presentation-project-bounding-box
1461             (ignore-errors             ;for empty presentation project
1462               (substitute
1463                #\, #\Space
1464                (string-trim
1465                 "BOX()"
1466                 (query
1467                  (sql-compile
1468                   `(:select
1469                     (:st_extent 'coordinates)
1470                     :from
1471                     (:as (:union
1472                           ,@(loop
1473                                for common-table-name in common-table-names
1474                                for point-table-name
1475                                = (point-data-table-name common-table-name)
1476                                ;; would have been nice, was too slow:
1477                                ;; = (aggregate-view-name common-table-name)
1478                                collect
1479                                `(:select
1480                                  'coordinates
1481                                  :from ',point-table-name
1482                                  :natural :left-join 'sys-presentation
1483                                  :where
1484                                  (:= 'presentation-project-id
1485                                      ,presentation-project-id))))
1486                          all-coordinates)))
1487                  :single!))))))
1488       (when presentation-project-bounding-box
1489         (setf (bounding-box presentation-project)
1490               presentation-project-bounding-box))
1491       (update-dao presentation-project))))
1492
1493 (defun remove-from-presentation-project (presentation-project-name
1494                                          &key measurement-ids acquisition-project)
1495   "Remove from presentation project presentation-project-name either a
1496 list of measurements (with measurement-id) or all measurements
1497 currently in acquisition-project with (denoted by its
1498 common-table-name).  Return nil if there weren't anything to remove."
1499   (assert-phoros-db-major-version)
1500   (let* ((presentation-project
1501           (car (select-dao 'sys-presentation-project
1502                            (:= 'presentation-project-name
1503                                presentation-project-name))))
1504          (presentation-project-id
1505           (Presentation-project-id presentation-project)))
1506     (flet ((remove-measurement (measurement-id)
1507              (let ((measurement
1508                     (car (select-dao
1509                           'sys-presentation
1510                           (:and (:= 'measurement-id measurement-id)
1511                                 (:= 'presentation-project-id
1512                                     presentation-project-id))))))
1513                (when measurement (delete-dao measurement)))))
1514     (cond (measurement-ids (mapc #'remove-measurement measurement-ids))
1515           (acquisition-project
1516            (dolist
1517                (measurement-id
1518                  (query
1519                   (:select
1520                    'measurement-id
1521                    :from 'sys-measurement 'sys-acquisition-project
1522                    :where (:and
1523                            (:= 'sys-acquisition-project.common-table-name
1524                                acquisition-project)
1525                            (:= 'sys-measurement.acquisition-project-id
1526                                'sys-acquisition-project.acquisition-project-id)))
1527                   :column))
1528              (remove-measurement measurement-id)))
1529           (t (error
1530               "Don't know what to remove.  ~
1531                Need either measurement-id or acquisition-project."))))))
1532
1533