utilities.lisp 32.9 KB
Newer Older
1
;;
2
;; Copyright 2002-2012 Genworks International
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;; 
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file.  If not, see
;; <http://www.gnu.org/licenses/>.
;; 


(in-package :gdl)

(defmacro with-error-handling ((&key (error? nil)
26
				     (timeout nil) 
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
                                     (timeout-body 
                                      `(warn "Timed Out after ~a Seconds" ,timeout))) 
                               &body body)
  "[Macro]. Wraps the <b>body</b> of code with error-trapping and system timeout. 
A warning is given if an error condition occurs with <b>body</b>. 

:&key ((timeout 2) \"Timeout in Seconds.\"
          timeout-body \"Body of code to evaluate if timeout occurs. 
                         Default is to print a warning and return nil.\")

:&rest (body \"Body of code to be wrapped\")"
  
  (declare (ignore timeout-body))
  
  (if error? `(progn ,@body)
    (let ((values (gensym)) (error (gensym)))
      (let ((code `(let* ((,values (multiple-value-list (ignore-errors ,@body)))

                          (,error (second ,values)))
                     (if (and ,error (typep ,error 'error))
                         (progn (warn "~a" ,error)
                           (values nil ,error))
                       (apply #'values ,values)))))
        (if timeout 
            (error "Need implementation for timeout in with-error-handling.~%")
          code)))))



(defun read-safe-string (string)
  "Lisp object. Reads an item from string, protecting against lisp evaluation with 
the `#.' reader macro. Throws an error if evaluation would have occured.

:arguments (string \"string\")

"
  (if (not (stringp string)) string
    (when (not (zerop (length string)))
      (let ((*read-eval* nil))
        (read-from-string string)))))

(defun alist2plist (alist)
  "Plist. Converts an assoc-list to a plist.

:arguments (alist \"Assoc-List\")
"
  
  (when alist
    (cons (first (first alist))
          (cons
           (second (first alist))
           (alist2plist (rest alist))))))


(defun replace-substring (string old new)
  "String. Replaces all substring occurrences of <b>old</b> with <b>new</b>
in <b>string</b>.

85
86
87
Note: In a full GDL system, you will have glisp:replace-regexp, which
      is more powerful and probably more efficient than this.

88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
:arguments (string \"String. The source string.\"
            old \"String. The substring to be replaced.\"
            new \"String. The substring to replace it with.\")

:see-also <tt>excl:replace-regexp</tt>

"
  
  (let ((position (search old string)))
    (if position
        (string-append 
         (subseq string 0 position) new
         (replace-substring (subseq string (+ position (length old))) old new))
      string)))

(defun lastcar (list)
  "Lisp Object. Returns the last element of <b>list</b>.

:arguments (list \"List\")"
  
  (first (last list)))


(defun mapsend (object-list message &rest args)
  "List. Returns a new list which is the result of sending <b>message</b> to each GDL 
object in <b>object-list</b>.

:arguments (object-list \"List of GDL objects.\"
            message \"Keyword symbol.\")"
117
118

  (declare (ignore args))
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
  
  (let ((object-list (if (typep object-list 'quantification)
                         (list-elements object-list)
                       object-list)))
    (mapcar #'(lambda(object)
                (the-object object (evaluate message))) object-list)))


(defun list-of-numbers (num1 num2 &optional (increment 1))
  "List of Numbers. Returns a list of incrementing numbers starting from 
<b>num1</b> and ending with <b>num2</b>, inclusive.

:arguments (num1 \"Number\"
            num2 \"Number\")
:&optional ((increment 1) \"Number. The distance between the returned listed numbers.\")"

  (let ((result-list nil))
    (dotimes (i (1+ (floor (/ (- num2 num1) increment))) (nreverse result-list))
      (push (+ (* i increment) num1) result-list))))


(defun half (num)
  "Number. Returns the result of dividing <b>num</b> by the integer <tt>2</tt>.
The type of the returned number will depend on the type of <b>num</b>.

:arguments (num \"Number\")"

  (/ num 2))

(defun twice (num)
  "Number. Returns the result of multiplying <b>num</b> by the integer <tt>2</tt>.
The type of the returned number will depend on the type of <b>num</b>.

:arguments (num \"Number\")"
  
  (+ num num))

(defun index-filter (fn list)
  "List. Returns all elements of <b>list</b> for whose index (starting at zero) the 
function <b>fn</b> returns non-NIL.

:arguments (fn \"Function object (e.g. a lambda expression)\"
            list \"List\")"
  
  (let ((count 0)
        (result-list nil))
    (dolist (elem list (nreverse result-list))
      (when (funcall fn count) (push elem result-list))
      (incf count))))


(defun flatten (tree)
  "List. Returns a new list consisting of only the leaf-level atoms from <b>list</b>. 
Since nil is technically a list, <tt>flatten</tt> also has the effect of removing 
nils from <b>list</b>, but may be inefficient if used only for this purpose. For 
removing nil values from a list, consider using <tt>remove nil ...</tt> instead.

:note from On Lisp by Paul Graham, code as follows:

  <pre>
  (if (atom tree)
      (ensure-list tree)
    (nconc (flatten (car tree))
           (if (cdr tree) (flatten (cdr tree)))))
  </pre>

:arguments (list \"List\")
:see-also <tt>remove</tt>"
  (if (atom tree)
      (ensure-list tree)
    (nconc (flatten (car tree))
           (if (cdr tree) (flatten (cdr tree))))))


(defun split (string &optional (split-chars (list #\space #\newline #\return #\tab)))
  
  "List of Strings. Returns a list containing the elements of <b>string</b> after having
been split according to <b>split-chars</b> as delimiting characters.

:arguments (string \"String\")
:&optional ((split-chars (list #\\space #\\newline #\\return #\\tab)) \"List of characters\")

201
:see-also <tt>glisp:split-regexp</tt>"
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
  
  (let ((split-chars (if (atom split-chars) (list split-chars) split-chars)))
    (let ((non-white
           (position nil string :test #'(lambda(item1 item2)
                                          (declare (ignore item1))
                                          (not (member item2 split-chars))))))
      (let ((newlines-before (count #\newline (subseq string 0 non-white))))
        (append (make-list newlines-before :initial-element :newline)
                (when non-white
                  (let ((white
                         (position nil (subseq string non-white)
                                   :test #'(lambda(item1 item2)
                                             (declare (ignore item1))
                                             (member item2 split-chars)))))
                    (cons (subseq string non-white (when white (+ white non-white)))
                          (when white (split (subseq string (+ non-white white)) split-chars))))))))))


(defun always (arg)
  "T. Always returns the value <tt>T</tt> regardless of <b>arg</b>.

:arguments (arg \"Lisp object. Ignored\")"
  
  (declare (ignore arg)) t)

(defun never (arg)
  "NIL. Always returns the value <tt>NIL</tt> regardless of <b>arg</b>.

:arguments (arg \"Lisp object. Ignored\")"
  (declare (ignore arg)))




;;
Dave Cooper's avatar
Dave Cooper committed
237
238
;; FLAG -- creates too many lists look into using some kind of
;;         sequence composition or series package
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
;;
(defun maptree (node fn &optional (accept? #'always)
                                  (prune?  #'never)
                                  (get-children :children))
  "List. Returns the results of applying <b>fn</b> to each GDL object in the object 
tree rooted at <b>node</b> in a ``depth-first'' tree traversal.

:arguments (node \"GDL object\"
            fn \"Function. Operates on a single argument which is a GDL object\")
:&optional ((accept? #'always) \"Function. Determines which nodes to accept in the final result\"
            (prune? #'never) \"Function. Determines which nodes to prune from the tree traversal\"
            (get-children :children) \"Keyword symbol :children or Function. Function applied to 
a given node to get its children. The default, keyword symbol :children, uses the node's normal
children as returned by (the-object node children).\")"

  (let ((object-list (flatten (traverse-tree node prune? get-children))))
    (mapcar fn (remove-if-not accept? object-list))))


(defun traverse-tree (node &optional prune? (get-children :children))
  (cons  node
         (when (not (funcall prune? node))         
           (mapcar #'(lambda(child)
                       (traverse-tree child prune? get-children))
                   (cond ((eql get-children :children)
                          (the-object node :children))
                         ((keywordp get-children)
                          (the-object node (evaluate get-children)))
                         ((functionp get-children)
                          (funcall get-children node))
                         (t (error
270
271
			     "
Get-Children arg of ~s Not Handled by traverse-tree" node)))))))
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507


(defun hash-table-copy (ht)
  (let ((new-hash (make-hash-table :size (hash-table-count ht) :test (hash-table-test ht))))
    (maphash #'(lambda(key val) (setf (gethash key new-hash) val)) ht) new-hash))

(defun hash-table-compare (ht1 ht2 &key (test 'equalp))
  (unless (and (= (hash-table-size ht1) (hash-table-size ht2)) 
               (eql (hash-table-test ht1) (hash-table-test ht2)))
    (error "For hash-table-compare, sizes and tests for hash tables must be the same"))
  (let ((new-hash (make-hash-table :size (hash-table-size ht1) :test (hash-table-test ht1))))
    (maphash #'(lambda(key val1) 
                 (let ((val2 (gethash key ht2)))
                   (setf (gethash key new-hash) (if (funcall test val1 val2) 'gdl-rule::%same% val1)))) 
             ht1) new-hash))
  
  



(defun expandit (form &optional (stream *standard-output*))
  (let ((*print-case* :downcase)
        (*print-right-margin* 60))
    (if (streamp stream)
        (pprint (macroexpand-1 (macroexpand-1 form)) stream)
      (with-open-file (stream stream :direction :output :if-exists :supersede :if-does-not-exist :create)
        (pprint (macroexpand-1 (macroexpand-1 form)) stream)))))
                    


(defun undefine-object (object-name-symbol)
  "NIL. Clears all definitions associated with <b>object-name</b> from the 
currently running GDL session.

:arguments (object-name \"Non-keyword Symbol naming a GDL object type\")"
  
  ;;
  ;; FLAG -- repeated code from define-object -- try to factor out.
  ;;
  (when (find-class object-name-symbol nil)
    (let ((message-keys (get object-name-symbol :%gdl-messages%)))
      (dolist (key message-keys)
        (let ((method (find-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) nil
                                   (list (find-class object-name-symbol)) nil)))
          (if (null method)
              (warn "No Method Found for Message ~s of object ~s~%" key object-name-symbol)
            (remove-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) method)))))
    (setf (find-class object-name-symbol) nil))
  (setf (get object-name-symbol :%gdl-messages%) nil))


(defun safe-sort (list &rest args)
  "List. Nondestructive analog of the Common Lisp <tt>sort</tt> function. 
Returns a freshly created list.

:arguments (list \"List. The list to be sorted.\")
:&rest (args \"Argument list. Identical to the arguments for Common Lisp <tt>sort</tt>.\")"
    
  (let ((copy (copy-list list)))
    (apply #'sort copy args)))


(defun gdl-object-symbol? (symbol) (eql (class-of (find-class symbol nil)) (find-class 'gdl-class)))
(deftype gdl-object-symbol () '(satisfies gdl-object-symbol?))

(defun gdl-format-symbol? (symbol) (eql (class-of (find-class symbol nil)) (find-class 'gdl-format-class)))
(deftype gdl-format-symbol () '(satisfies gdl-format-symbol?))

;;
;; From Paul Graham ACL
;;
(defun most (function list)
  "List. Returns the member of <b>list</b> which returns the maximum numerical value
when <b>function</b> is applied to it. As second value is returned which is the
actual maximum value (the return-value of <b>function</b> as applied). This function 
comes from the Paul Graham book <u>ANSI Common Lisp</u>.

:arguments (function \"Function\"
            list \"List\")"

  (if (null list)
      (values nil nil)
    (let* ((wins (first list))
           (max (funcall function wins)))
      (dolist (obj (rest list))
        (let ((score (funcall function obj)))
          (when (> score max)
            (setq wins obj max score))))
      (values wins max))))



(defun least (function list)
  "List. Returns the member of <b>list</b> which returns the minimum numerical value
when <b>function</b> is applied to it. As second value is returned which is the
actual minimum value (the return-value of <b>function</b> as applied). This function 
comes from the Paul Graham book <u>ANSI Common Lisp</u>.

:arguments (function \"Function\"
            list \"List\")"

  (if (null list)
      (values nil nil)
    (let* ((wins (first list))
           (min (funcall function wins)))
      (dolist (obj (rest list))
        (let ((score (funcall function obj)))
          (when (< score min)
            (setq wins obj min score))))
      (values wins min))))


(defun ^2  (number)
  "Number. Return <b>number</b> raised to the power two (2).

:arguments (number \"Number\")"
  
  (* number number))


(defun number-round (number &optional decimal-places)
  "Number. Returns <b>number</b> rounded to <b>decimal-places</b> decimal places.

:arguments (number \"Number\"
            decimal-places \"Integer\")"

  (if (null decimal-places)
      number
    (coerce (/ (round (* number (expt 10 decimal-places))) (expt 10 decimal-places)) 'double-float)))

(defun number-format (number &optional decimal-places)
  "String. Returns a string displaying <b>number</b> rounded to <b>decimal-places</b> decimal places.

:arguments (number \"Number\"
            decimal-places \"Integer\")"
  
  (let ((rep (number-round number decimal-places)))
    (if (and (or (null decimal-places) (zerop decimal-places)) (= rep (truncate rep))) (format nil "~a" (truncate rep))
      (format nil (format nil "~~,~af" decimal-places) (coerce rep 'double-float)))))

;;
;; FLAG -- handle points of 2 and 4 dimensions.
;;


(defun near-to? (number near-to &optional (tolerance *zero-epsilon*))
  "Boolean. Predicate to test if number is within tolerance of 
<b>near-to</b>. The default tolerance is the value of the parameter 
<tt>*zero-epsilon*</tt>.

:arguments (number \"Number\"
            near-to \"Number\")
:&optional ((tolerance *zero-epsilon*) \"Number\")"

  (< (abs (- number near-to)) tolerance))

(defun near-zero? (number &optional (tolerance *zero-epsilon*))
  "Boolean. Returns non-NIL iff <b>number</b> is greater than <b>tolerance</b> different
from zero.

:arguments (number \"Number\")
:&optional ((tolerance *zero-epsilon*) \"Number\")
:see-also <tt>zerop</tt> (Common Lisp function)"
             
  (near-to? number 0 tolerance))


(defun status-message (string)
  "NIL. Prints <b>string</b>, followed by a newline, to <tt>*trace-output*</tt>, 
which is generally the system console.

:arguments (string \"String\")"

  (write-string string *trace-output*)
  (format *trace-output* "~%"))



(defun safe-float (number)
  "Double-float Number. Coerces <b>number</b> to a double-precision floating-point
number if possible. If this is not possible, returns <tt>0.0d0</tt> (i.e. zero in the form
of a double-precision floating-point number).

:arguments (number \"Number\")"
  
  (if (typep number '(or integer float ratio))
      (coerce number 'double-float) 
    0.0d0))


(defun round-to-nearest (number interval)
  "Number. Rounds <b>number</b> to the nearest <b>interval</b>.

:arguments (number \"Number\"
            interval \"Number\")"
  ;;(* (round number interval) interval)
  
  (/ (round number interval) (/ interval))
  )


(defun fround-to-nearest (number interval)
  "Number. Rounds <b>number</b> to the nearest <b>interval</b>,
using type contagion rules for floating-point similar to the 
CL \"fround\" function.

:arguments (number \"Number\"
            interval \"Number\")"
  
  (* (fround number interval) interval))


(defun find-all-superclasses (class &optional (local? nil))
  (let ((directs (glisp:direct-superclasses class)))
    (if local? directs
      (remove-duplicates 
       (flatten (mapcan #'(lambda(direct)
                            (list direct (find-all-superclasses direct))) 
                        directs)) :from-end t))))

(defun symbols-as-keywords (item)
  (when item
    (cond ((symbolp item) (make-keyword item))
          ((listp item) (mapcar #'symbols-as-keywords item))
          (t item))))
        

(defmethod readable-expression ((object t) &optional self) 
  (declare (ignore self))
  (error "Objects of type ~a cannot currently be written out and read back into GDL reliably.
 Please do not use objects of this type as the value for toplevel inputs or settable slots, 
 or contact Genworks with an enhancement request to include a readble output format for 
 this object type." (type-of object)))


(defmethod readable-expression ((object hash-table) &optional self) 
508
509
510
511
512
513
514
515
516
517
518
519
  (let (keys vals)
    (maphash #'(lambda(key val) (push key keys) (push val vals)) object)
    `(let ((ht (make-hash-table)))
       (mapc #'(lambda(key val)
		 (setf (gethash key ht) val))
	     ,(readable-expression (nreverse keys) self)
	     ,(readable-expression (nreverse vals) self)) ht)))

(defmethod readable-expression ((object cons) &optional self)  
           (with-error-handling (:timeout nil) `(list ,@(mapcar #'(lambda(expr)
								    (readable-expression expr self))
								object))))
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611

(defmethod readable-expression ((object number) &optional self) (declare (ignore self)) object)
(defmethod readable-expression ((object string) &optional self) (declare (ignore self)) object)
(defmethod readable-expression ((object symbol) &optional self) (declare (ignore self)) 
           `',object)
(defmethod readable-expression ((object array) &optional self) (declare (ignore self)) object)

(defmethod lookup-color ((color string) &key (format :decimal) (ground :foreground))
  (if (and (eql (aref color 0) #\#) (= (length color) 7))
      (ecase format 
        (:hex color)
        (:decimal (let ((red (subseq color 1 3))
                        (green (subseq color 3 5))
                        (blue (subseq color 5 7)))
                    (let* ((*read-base* 16) 
                           (red (to-single-float (div (read-safe-string red) 255)))
                           (green (to-single-float (div (read-safe-string green) 255)))
                           (blue (to-single-float (div (read-safe-string blue) 255))))
                      (values (make-array 3 :initial-contents (list red green blue)) t)))))
    
    (progn
      (when (= (length color) 6)
        (setq color (string-append "#" color)))

      (ecase format 
        (:decimal (multiple-value-bind (decimal found?)  (gethash color *color-table-decimal*)
                    (values (coerce (or decimal (lookup-color (getf *colors-default* ground) :format :decimal)) 'vector) found?)))
        (:hex     (if (eql (aref color 0) #\#) (values color t)
                    (multiple-value-bind (hex found?) (gethash (make-keyword color) *color-table*)
                      (values (or hex (lookup-color (getf *colors-default* ground) :format :hex)) found?))))))))

(defmethod lookup-color ((color symbol) &key (format :decimal) (ground :foreground))
  (ecase format 
    (:decimal (multiple-value-bind (decimal found?)  (gethash color *color-table-decimal*)
                (values (coerce (or decimal (lookup-color (getf *colors-default* ground) :format :decimal)) 'vector) found?)))
    (:hex (multiple-value-bind (hex found?) (gethash (make-keyword color) *color-table*)
            (values (or hex (lookup-color (getf *colors-default* ground) :format :hex)) found?)))))


(defmethod lookup-color ((color vector) &key (format :decimal) (ground :foreground))
  (declare (ignore ground))
  (ecase format 
    (:decimal (values (map 'vector #'to-single-float color)  t))
    (:hex (setq color (make-array 3 :initial-contents (list (truncate (* (aref color 0) 255))
                                                            (truncate (* (aref color 1) 255))
                                                            (truncate (* (aref color 2) 255)))))
          (string-upcase (let ((*print-base* 16)) (values (format nil "#~2,,,'0@a~2,,,'0@a~2,,,'0@a" 
                                                                  (aref color 0)(aref color 1)(aref color 2)) t))))))



(defmethod lookup-color ((color cons) &key (format :decimal) (ground :foreground))
  (declare (ignore ground))
  (ecase format 
    (:decimal (values (coerce (mapcar #'to-single-float color) 'vector) t))
    (:hex (let ((*print-base* 16)) (values (format nil "#~2,,,'0@a~2,,,'0@a~2,,,'0@a" 
                                                   (truncate (* (first color) 255))
                                                   (truncate (* (second color) 255))
                                                   (truncate (* (third color) 255))) t)))))

(defmethod lookup-color ((color null) &key (format :decimal) (ground :foreground))
  (values (lookup-color (getf *colors-default* ground) :format format) nil))
     
                
(defun cyclic-nth (number list)
  "Lisp object. Returns nth from the list, or wraps around if nth is greater than the length of the list."
  (nth (mod number (length list)) list))



(defun set-self (object)
  (setf (symbol-value 'self) object))


(eval-when (compile load eval) (export 'with-error-handling))
                
                
                
(defmethod evaluate-object ((category t) args)
  (cons category args))


(defun iso-8601-date (universal-time &key include-time?)
  "String. Returns the ISO8601 formatted date and possibly time from a
Common Lisp universal time integer, e.g. 2007-11-30 or
2007-11-30T13:45:10" 
  (multiple-value-bind (seconds minutes hours date month year day daylight-savings? timezone)
      (decode-universal-time universal-time)
    (declare (ignore day daylight-savings? timezone))
    (format nil "~a-~2,,,'0@a-~2,,,'0@a~a" year month date
            (if include-time? (format nil "T~2,,,'0@a:~2,,,'0@a:~2,,,'0@a" hours minutes seconds) ""))))

612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
(defun universal-time-to-plist (universal-time)
  (multiple-value-bind (seconds minutes hours date month year)
      (decode-universal-time universal-time)
    (list :seconds (format nil "~2,,,'0@a" seconds)
	  :minutes (format nil "~2,,,'0@a" minutes)
	  :hours (format nil "~2,,,'0@a" hours)
	  :date (format nil "~2,,,'0@a" date)
	  :month (format nil "~2,,,'0@a" month)
	  :year (format nil "~a" year)
	  :full-date (format nil "~a-~2,,,'0@a-~2,,,'0@a" year month date))))


(defun universal-time-from-iso-8601 (iso8601-date)
  "Integer representing Common Lisp Universal Time. Returns the universal time from a date formatted as 
an iso-8601 date, optionally with time, e.g. 2012-07-08 or 2012-07-08T13:33 or 2012-07-08T13:33:00"
  (destructuring-bind (date &optional (time "00:00:00"))
628
629
630
631
632
      ;;(glisp:split-regexp "t" (string-downcase iso8601-date))
      (split (string-downcase iso8601-date) #\t)
    (destructuring-bind  (year month date) 
	;;(glisp:split-regexp "-" date)
	(split date #\-)
633
      (destructuring-bind (hours minutes &optional (seconds "00"))
634
635
	  ;;(glisp:split-regexp ":" time)
	  (split time #\:)
636
637
638
639
640
641
	(encode-universal-time (parse-integer seconds)
			       (parse-integer minutes)
			       (parse-integer hours)
			       (parse-integer date)
			       (parse-integer month)
			       (parse-integer year))))))
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676

(defun print-hash (hash) 
  (maphash #'(lambda(key val) (print-variables key val)) hash))

(defun list-hash (hash) 
  (let (result)
    (maphash #'(lambda(key val)
                 (if result (nconc result (list key val))
                   (setq result (list key val)))) hash) result))


(defun make-fresh-copy (&key object make-object-args)
  
  (apply #'make-object (the-object object type) make-object-args))
  

(defun read-snapshot (&key (filename "/tmp/snap.gdl") object keep-bashed-values? make-object-args keys-to-ignore)
  "GDL Instance. Reads the snapshot file indicated by filename. If no optional keyword <tt>object</tt>
argument is given, a new GDL instance based on the data in the snapshot file is returned. If an
<tt>object</tt> is given, the object should be compatible in type to that specified in the 
snapshot file, and this existing object will be modified to contain the set slot values and
toplevel inputs as specified in the snapshot file.

:&key ((filename \"/tmp/snap.gdl\") \"String or pathname. File to be read.\"
       (keep-bashed-values? nil) \"Boolean. Indicates whether to keep the currently bashed values in object before reading snap values into it.\"
       (object nil) \"GDL object. Existing object to be modified with restored values.\")"
  (with-open-file (in filename)
    (let ((package-form (read in)))
      (when (or (null package-form) (not (find-package (second package-form))))
        (error "Invalid package specification at beginning of ~a.~%" filename))
      (let* ((*package* (find-package (second package-form))) (root-form (read in)))
        (when (or (null root-form) 
                  (not (eql (class-of (find-class (first root-form))) (find-class 'gdl-class)))
                  ;;(not (find :%gdl-messages% (symbol-plist (first root-form))))
                  )
677
          (error "Invalid object type specifier as first element of second form in ~a.~%" root-form))
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
        
        (let ((object (cond ((and object keep-bashed-values?) object)
                            (object (the-object object restore-tree!) object)
                            (t (progn
                                 (apply #'make-object (first root-form) make-object-args))))))
          
          (let ((self object) (value-plist (rest root-form)))
            (mapc #'(lambda(key expression) 
                      (unless (member key keys-to-ignore)
                        (when self (the-object self (set-slot! key (eval expression))))))
                  (plist-keys value-plist) (plist-values value-plist)))
          
          (let ((forms-ht (make-hash-table)))
            (do ((form (read in nil nil) (read in nil nil)))
                ((null form))
              (push form (gethash (length (first form)) forms-ht)))
            (let* ((forms (list-hash forms-ht))
                   (forms (mapcar #'list (plist-keys forms) (plist-values forms)))
                   (forms (plist-values (alist2plist (sort forms #'< :key #'first))))
                   (forms (mapcar #'(lambda(group)
                                      (let ((primaries (remove-if-not #'(lambda(item) (or (getf (rest item) :%primary?%)
                                                                                          (getf (rest item) :element-index-list))) group))
                                            (non-primaries (remove-if #'(lambda(item) (or (getf (rest item) :%primary?%)
                                                                                          (getf (rest item) :element-index-list))) group)))
                                        (append primaries non-primaries))) forms))
                   (forms (apply #'append forms)))
              
              (dolist (form forms)
            
                (let ((root-path (first form)) (value-plist (rest form)))
                  (let ((self 

                         (with-error-handling (:timeout nil)
                           (the-object object (follow-root-path root-path)))))
                
                    (when self
                      (mapc #'(lambda(key expression) 
                                (unless (member key keys-to-ignore)
                                  (when self 
                                    (the-object self (set-slot! key (eval expression))))))
                            (plist-keys value-plist) (plist-values value-plist))))))))
          object)))))



(defun write-plist (&key plist output-path)
  "Pretty-prints a plist to a file with standard I/O syntax.

:&key ((plist nil) \"List. The list to be printed to the file\"
       (output-path nil) \"Pathname of a file. The file to be created or superseded.\")

"
  (with-open-file (out   output-path
                   :direction :output
                   :if-exists :new-version
                   :if-does-not-exist :create)
        (with-standard-io-syntax
          (pprint plist out))))
  



(defun min-max-search (function comparison low high &optional (tolerance *zero-epsilon*) verbose?)

  (when verbose? (print-variables high low))
  
  (if (near-to?  high low tolerance) high
    (let* ((mid (half (+ low high)))
           (lower (half (+ low mid)))
           (upper (half (+ mid high)))
           (lower-value (funcall function lower))
           (upper-value (funcall function upper)))
      
      (if (funcall comparison lower-value upper-value)
          (min-max-search function comparison low mid tolerance verbose?)
        (min-max-search function comparison mid high tolerance verbose?)))))


(defun binary-search (function value low high &optional (tolerance *zero-epsilon*) verbose?)

  
  (when verbose? (print-variables high low))
  
  (if (near-to?  high low tolerance)
      (progn (warn "binary search did not converge, returning best guess")
             high)
    (let* ((mid (half (+ low high)))
           (mid-value (funcall function mid)))
      
      (print-variables mid mid-value)
      
      (cond ((near-to? mid-value value tolerance) mid)
            ((> mid-value value) (binary-search function value low mid tolerance verbose?))
            ((< mid-value value) (binary-search function value mid high tolerance verbose?))))))
772
773
774



775
776
(defun gdl-rule::lookup-parameters (self message)
  (let ((value (getf (the %parameters%) message 'gdl-rule:%not-handled%)))
Dave Cooper's avatar
Dave Cooper committed
777
778
779
780
781
782
783
    (if (eql value 'gdl-rule:%not-handled%) (not-handled self message) value)))


(defparameter *dep-hash-threshhold* 1000)


(defun add-notify-cons (notify-cons value &optional self message)
784
785
786
787
788
789
790
791
  ;;
  ;; FLAG -- this was added as a fix for github Issue #69, but causes
  ;; a regression by polluting the dependency graph with normal objects 
  ;; which may then become unbound spuriously. Retracted until a more
  ;; benign fix for Issue #69 can be determined. 
  ;;
  (declare (ignore self message))
  #+nil
Dave Cooper's avatar
Dave Cooper committed
792
  (when (and self message)
793
794
795
796
797
798
    (let ((aggregate  (gdl-acc::%aggregate% (first notify-cons))))
      (when (and (consp aggregate)
		 (not (consp (gdl-acc::%aggregate% self))))
	(let ((num-value (gdl-acc::number-of-elements (first aggregate))))
	  (when (consp num-value)
	    (add-notify-cons (list self message) num-value))))))
Dave Cooper's avatar
Dave Cooper committed
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
  (let ((second (second value)))
    (if (and (listp second) (< (length second) *dep-hash-threshhold*))
	(let ((matching-sublist (assoc (first notify-cons) (second value))))
	  (if matching-sublist (pushnew (second notify-cons) (rest matching-sublist))
	      (push (copy-list notify-cons) (second value))))
	(progn    
	  (when (listp second) (setf (second value) (alist-to-hash second)))
	  (pushnew (second notify-cons) (gethash (first notify-cons) (second value)))))))


(defun alist-to-hash (alist)
  (let ((ht (make-hash-table :size (twice *dep-hash-threshhold*) :rehash-size *dep-hash-threshhold*)))
    (dolist (entry alist ht)
      (destructuring-bind (object . messages) entry
	(setf (gethash object ht) messages)))))


#+nil
(defun add-notify-cons (notify-cons value &optional self message)

  (when (and self message)
    (let ((aggregate  (gdl-acc::%aggregate% (first notify-cons))))
      (when (consp aggregate)
	(add-notify-cons (list self message) 
			 (gdl-acc::number-of-elements (first aggregate))))))
  
  (let ((matching-sublist (assoc (first notify-cons) (second value))))
    (if matching-sublist (pushnew (second notify-cons) (rest matching-sublist))
	(push (copy-list notify-cons) (second value)))))