(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(filecreated "12-Mar-88 15:42:46" {erinyes}<lispusers>lyric>tmax-date.\;2 15254
|changes| |to:| (fns current.display.font)
|previous| |date:| "30-Dec-87 11:39:18" {erinyes}<lispusers>lyric>tmax-date.\;1)
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
(prettycomprint tmax-datecoms)
(rpaqq tmax-datecoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.)
(* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|)
(* * tmax-datenil |ImageObject| |functions|)
(fns dateobj dateobjp date.displayfn date.imageboxfn date.putfn date.getfn
date.copyfn date.buttoneventinfn)
(* * |Date| |support| |functions|)
(fns current.display.font change.date.format)
(* * |Functions| |to| |change| |date| |format|)
(fns findtime findhour ampm findday nump findmonth findyear)
(vars date.format.items)
(records daterecord)))
(* |Developed| |under| |support| |from| nih |grant| rr-00785.)
(* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|)
(* * tmax-datenil |ImageObject| |functions|)
(defineq
(dateobj
(lambda (date/time date.string template) (* |fsg| "13-Jul-87 11:51")
(* * |Create| |an| |instance| |of| \a date |imageobj.|)
(let* ((template.type (or template '(m d y f)))
(dateandtime (or date/time (mkstring (date))))
(displaydate (or date.string (change.date.format dateandtime template.type)))
(newobj (imageobjcreate (|create| daterecord
datestring ← dateandtime
display.date ← displaydate
template.date ← template.type)
\\dateobj.imagefns)))
(imageobjprop newobj 'type 'dateobj)
newobj)))
(dateobjp
(lambda (imobj) (* |ss:| "27-Jun-87 15:39")
(* |Tests| |an| |imageobj| |to| |see| |if| |it| |is| \a |date| |imageobject.|
b\y |convention,| |testing| |functions| |for| |an| |imageobject| |will| |be|
|named| (concat |<type| |of| |imageobj>| "P"))
(and imobj (eq (imageobjprop imobj 'type)
'dateobj))))
(date.displayfn
(lambda (obj stream streamtype hoststream) (* |fsg| "17-Sep-87 10:44")
(* * |Display| |function| |for| |date| |imageobjs.|)
(tmax.shadeobj obj stream)
(prin1 (|fetch| display.date |of| (|fetch| objectdatum |of| obj))
stream)))
(date.imageboxfn
(lambda (obj stream currentx rightmargin) (* |ss:| "27-Jun-87 15:38")
(* * |Return| |the| |ImageBox| |for| |the| |date| |string.|
|The| |size| |is| |determined| |by| |the| |stream's| |current| |font.|)
(dspfont (current.display.font stream)
stream)
(|create| imagebox
xsize ← (stringwidth (|fetch| display.date |of| (|fetch| objectdatum |of| obj))
stream)
ysize ← (fontprop stream 'height)
ydesc ← (fontprop stream 'descent)
xkern ← 0)))
(date.putfn
(lambda (obj stream) (* |ss:| "27-Jun-87 15:38")
(prin2 (list '|Date| (|fetch| objectdatum |of| obj))
stream)))
(date.getfn
(lambda (stream copy.object) (* |fsg| "20-Aug-87 14:56")
(let ((window (|with| textobj textobj (car \\window))))
(tsp.setup.fmmenu window))
(apply (function dateobj)
(or copy.object (cadr (read stream))))))
(date.copyfn
(lambda (image.obj source.stream target.stream) (* |fsg| "23-Jul-87 11:34")
(* * |Here| |to| copy \a |Date| |Image| |Object.|)
(selectq (imagestreamtype target.stream)
(text (let ((textobj (textobj target.stream)))
(apply* (imageobjprop image.obj 'getfn)
target.stream
(|fetch| objectdatum |of| image.obj))))
(error "Unknown TARGET stream type" (imagestreamtype target.stream)))))
(date.buttoneventinfn
(lambda (obj windowstream selection relx rely window hoststream button)
(* |fsg| "11-Aug-87 13:56")
(and (mousestate middle)
(let ((old.date (|fetch| objectdatum |of| obj))
(new.date (menu (|create| menu
title ← '|Date/Time Menu|
items ← date.format.items
centerflg ← t))))
(and new.date (not (equal (|fetch| (daterecord template.date) |of| old.date)
new.date))
(progn (|with| daterecord old.date (cond
((listp new.date)
(setq display.date (change.date.format
datestring new.date))
(setq template.date new.date))
(t (setq datestring (mkstring (date)))
(setq display.date (change.date.format
datestring
template.date)))))
'changed))))))
)
(* * |Date| |support| |functions|)
(defineq
(current.display.font
(lambda (stream) (* \; "Edited 12-Mar-88 15:28 by drc:")
(* |;;;| "Return the current font. This function is here instead of TMAX because the DATE code is also used in the LetterHead code.")
(let ((current.font (|fetch| clfont |of| (|with| textstream (textstream textobj)
currentlooks))))
(cond
((typenamep current.font 'fontdescriptor)
current.font)
((typenamep current.font 'fontclass)
(|fetch| displayfd |of| current.font))
(t (shouldnt "Can't get current font"))))))
(change.date.format
(lambda (date template) (* |ss:| "27-Jun-87 15:36")
(* * |Convert| |the| |string| date |to| |the| |format| |specified| |by|
template.)
(cond
(template (let ((version (|if| (equal (last template)
'(a))
|then| 'abbrev
|else| (|if| (equal (last template)
'(f))
|then| 'full
|else| 'euro)))
(funclst '((d findday)
(m findmonth)
(y findyear))))
(cond
((eq (car template)
t)
(findtime date version))
(t (let ((ch (|if| (eq version 'abbrev)
|then| "/"
|else| " ")))
(concat (apply (cadr (assoc (car template)
funclst))
(list date version))
ch
(apply (cadr (assoc (cadr template)
funclst))
(list date version))
(|if| (equal ch " ")
|then| ", "
|else| ch)
(apply (cadr (assoc (caddr template)
funclst))
(list date version))))))))
(t (date)))))
)
(* * |Functions| |to| |change| |date| |format|)
(defineq
(findtime
(lambda (olddate version) (* |ss:| "27-Jun-87 15:40")
(let ((hour (substring olddate 11 12))
(minutes (substring olddate 14 15)))
(|if| (equal version 'abbrev)
|then| (concat (findhour hour)
":" minutes " " (ampm hour))
|else| (|if| (equal version 'euro)
|then| (substring olddate 11 15)
|else| (concat (selectq (|if| (lessp (mkatom minutes)
46)
|then| (mkatom (findhour hour))
|else| (plus 1 (mkatom (findhour hour))))
(1 "one")
(2 "two")
(3 "three")
(4 "four")
(5 "five")
(6 "six")
(7 "seven")
(8 "eight")
(9 "nine")
(10 "ten")
(11 "eleven")
(12 "twelve")
nil)
" "
(|if| (and (greaterp (mkatom minutes)
15)
(lessp (mkatom minutes)
45))
|then| "thirty"
|else| "o'clock")
" "
(|if| (and (greaterp (mkatom minutes)
44)
(equal (findhour hour)
"11"))
|then| (|if| (equal (ampm hour)
"a.m.")
|then| "p.m."
|else| "a.m.")
|else| (ampm hour))))))))
(findhour
(lambda (hour) (* |ss:| " 8-Feb-86 17:49")
(cond
((lessp (mkatom hour)
13)
(cond
((lessp (mkatom hour)
10)
(mkstring (cadr (unpack hour))))
(t hour)))
(t (mkstring (selectq (mkatom hour)
(13 1)
(14 2)
(15 3)
(16 4)
(17 5)
(18 6)
(19 7)
(20 8)
(21 9)
(22 10)
(23 11)
(24 12)
nil))))))
(ampm
(lambda (hour)
(|if| (or (lessp (mkatom hour)
12)
(equal (mkatom hour)
24))
|then| "a.m."
|else| "p.m.")))
(findday
(lambda (olddate version) (* |shw:| " 1-Jul-85 11:28")
(mkatom (|if| (nump (substring olddate 1 2))
|then| (substring olddate 1 2)
|else| (substring olddate 2 2)))))
(nump
(lambda (n) (* |edited:| " 4-Apr-86 17:55")
(* |changed|)
(not (null (numberp (mkatom n))))))
(findmonth
(lambda (olddate version) (* |ss:| "27-Jun-87 15:40")
(prog ((dates '((|Jan| 1 |January|)
(|Feb| 2 |February|)
(|Mar| 3 |March|)
(|Apr| 4 |April|)
(|May| 5 |May|)
(|Jun| 6 |June|)
(|Jul| 7 |July|)
(|Aug| 8 |August|)
(|Sep| 9 |September|)
(|Oct| 10 |October|)
(|Nov| 11 |November|)
(|Dec| 12 |December|)))
(output nil))
(|if| (eq version 'abbrev)
|then| (setq output (car (cdr (assoc (mkatom (substring olddate 4 6))
dates))))
|else| (setq output (car (cddr (assoc (mkatom (substring olddate 4 6))
dates)))))
(return output))))
(findyear
(lambda (olddate version) (* |ss:| "27-Jun-87 15:41")
(|if| (eq version 'abbrev)
|then| (mkatom (substring olddate 8 9))
|else| (mkatom (concat "19" (substring olddate 8 9))))))
)
(rpaqq date.format.items ((|Month Day, Year| '(m d y f)
"Insert current date as \"March 8, 1952\"")
(|Month/Day/Year| '(m d y a) "Insert current date as \"3/8/52\"")
(|Day Month, Year| '(d m y f)
"Insert current date as \"8 March, 1952\"")
(|Day/Month/Year| '(d m y a) "Insert current date as \"8/3/52\"")
(|Time| '(t f) "Insert current time as \"four thirty p.m.\"")
(|Numbered Time| '(t a) "Insert current time as \"4:30 p.m.\"")
(|Military Time| '(t e) "Insert current time as \"16:30\"")
(|Update| t "Convert to current date/time")))
(declare\: eval@compile
(record daterecord (datestring display.date template.date))
)
(putprops tmax-date copyright ("Xerox Corporation" 1987 1988))
(declare\: dontcopy
(filemap (nil (1398 6132 (dateobj 1408 . 2175) (dateobjp 2177 . 2611) (date.displayfn 2613 . 2935) (
date.imageboxfn 2937 . 3564) (date.putfn 3566 . 3764) (date.getfn 3766 . 4060) (date.copyfn 4062 .
4594) (date.buttoneventinfn 4596 . 6130)) (6174 8957 (current.display.font 6184 . 6890) (
change.date.format 6892 . 8955)) (9012 14248 (findtime 9022 . 11531) (findhour 11533 . 12290) (ampm
12292 . 12496) (findday 12498 . 12769) (nump 12771 . 13000) (findmonth 13002 . 13980) (findyear 13982
. 14246)))))
stop