(FILECREATED "18-Feb-87 15:42:27" {SUMEX-AIM}PS:<TMAX.SOURCES>DATE.;4 19668
previous date: "17-Feb-87 14:29:37" {SUMEX-AIM}<GILMURRAY.LISP>DATE.;7)
(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.)
(PRETTYCOMPRINT DATECOMS)
(RPAQQ DATECOMS ((* Developed under support from NIH grant RR-00785.)
(* Written by Frank Gilmurray and Sami Shaio.)
(FNS DATEOBJ DATEOBJP DATE.DISPLAYFN DATE.IMAGEBOXFN CURRENT.DISPLAY.FONT DATE.PUTFN
DATE.GETFN DATE.BUTTONEVENTINFN DATES.TEMPLATE AMPM DATES.MENU.APPLY
DATES.MENU.WHENSELECTEDFN DATES.SET FINDDAY FINDHOUR FINDMONTH FINDTIME FINDYEAR NUMP
WHICHDATE)
(RECORDS DATEOBJ STREAM FONTCLASS)))
(* Developed under support from NIH grant RR-00785.)
(* Written by Frank Gilmurray and Sami Shaio.)
(DEFINEQ
(DATEOBJ
(LAMBDA (TEMPLATE) (* fsg "23-Jul-86 09:53")
(* Create an instance of a date imageobj.
A dateobj is also defined as a record with a
datestring field. *)
(LET* ((TEMPLATE.TYPE (OR TEMPLATE '(M D Y F)))
(DATEANDTIME (MKSTRING (DATE)))
(DISPLAYDATE (MKSTRING (DATES.TEMPLATE DATEANDTIME TEMPLATE.TYPE)))
(NEWOBJ (IMAGEOBJCREATE (create DATEOBJ
DATESTRING ← DATEANDTIME
DISPLAY.DATE ← DISPLAYDATE
TEMPLATE.DATE ← TEMPLATE.TYPE)
(IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN)
(FUNCTION DATE.IMAGEBOXFN)
(FUNCTION DATE.PUTFN)
(FUNCTION DATE.GETFN)
(FUNCTION NILL)
(FUNCTION DATE.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)))))
(* By convention, every image object will have a type
property associated with it that will facilitate
imageobj mapping in a TEdit file.)
(IMAGEOBJPROP NEWOBJ 'TYPE
'DATEOBJ)
NEWOBJ)))
(DATEOBJP
(LAMBDA (IMOBJ) (* ss: "24-Jun-85 16:33")
(* Tests an imageobj to see if it is a date imageobject. By 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-Feb-87 09:28")
(* * Display function for date imageobjs.)
(PRIN1 (fetch DISPLAY.DATE of (fetch OBJECTDATUM of OBJ))
STREAM)))
(DATE.IMAGEBOXFN
(LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN) (* fsg "15-Feb-87 14:05")
(* * 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)))
(CURRENT.DISPLAY.FONT
(LAMBDA (STREAM) (* fsg "17-Feb-87 10:19")
(* * 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 (CAR (fetch \WINDOW
of 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"))))))
(DATE.PUTFN
(LAMBDA (DATEOBJ STREAM) (* fsg " 4-Feb-87 09:40")
(PRIN2 (LIST 'Date
(fetch (DATEOBJ TEMPLATE.DATE) of (fetch OBJECTDATUM of DATEOBJ)))
STREAM)))
(DATE.GETFN
(LAMBDA (STREAM) (* fsg " 4-Feb-87 09:42")
(OR (WINDOWPROP (PROCESSPROP (THIS.PROCESS)
'WINDOW)
'IMAGEOBJ.MENUW)
(AND (FGETD 'TSP.FMMENU)
(TSP.FMMENU (TEXTSTREAM (PROCESSPROP (THIS.PROCESS)
'WINDOW)))))
(APPLY 'DATEOBJ
(CDR (READ STREAM)))))
(DATE.BUTTONEVENTINFN
(LAMBDA (DATEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON)
(* fsg "26-Jan-87 10:06")
(AND (MOUSESTATE MIDDLE)
(LET ((DATE.MENU (create MENU
TITLE ← "Date Menu"
ITEMS ← '((Month% Day,% Year (DATES.TEMPLATE DATE
'(M D Y F))
"Insert current date as %"March 8, 1952%"")
(Month/Day/Year (DATES.TEMPLATE DATE '(M D Y A))
"Insert current date as %"3/8/52%"")
(Day% Month,% Year (DATES.TEMPLATE DATE
'(D M Y F))
"Insert current date as %"8 March, 1952%"")
(Day/Month/Year (DATES.TEMPLATE DATE '(D M Y A))
"Insert current date as %"8/3/52%"")
(Time (DATES.TEMPLATE DATE '(T F))
"Insert current time as %"four thirty p.m.%"")
(Numbered% Time (DATES.TEMPLATE DATE '(T A))
"Insert current time as %"4:30 p.m.%"")
(Military% Time (DATES.TEMPLATE DATE '(T E))
"Insert current time as %"16:30%""))
WHENSELECTEDFN ←(FUNCTION DATES.MENU.WHENSELECTEDFN))))
(PUTMENUPROP DATE.MENU 'IMAGEOBJ
DATEOBJ)
(MENU DATE.MENU)
'CHANGED))))
(DATES.TEMPLATE
(LAMBDA (DATE TEMPLATE) (* fsg "24-Jul-86 14:43")
(* * comment)
(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))))))))
(DATE))))
(AMPM
(LAMBDA (HOUR)
(if (OR (LESSP (MKATOM HOUR)
12)
(EQUAL (MKATOM HOUR)
24))
then "a.m."
else "p.m.")))
(DATES.MENU.APPLY
(LAMBDA (ITEM MENU) (* fsg "31-Jul-86 10:18")
(* This function serves the purpose of calculating the stream and the editing window from information stored on the
window containing the menu. It then applies the appropiate function for each ITEM in the menu*)
(SETQ ITEM (COND
((ATOM ITEM)
ITEM)
(T (CAR ITEM))))
(LET* ((DATE.RECORD (fetch OBJECTDATUM of (GETMENUPROP MENU 'IMAGEOBJ)))
(DATE (fetch DATESTRING of DATE.RECORD)))
(COND
((fetch ITEMS of MENU)
(LET ((FUNCALL (CADR (ASSOC ITEM (fetch ITEMS of MENU)))))
(replace DISPLAY.DATE of DATE.RECORD with (EVAL FUNCALL))
(replace TEMPLATE.DATE of DATE.RECORD with (CADAR (LAST FUNCALL)))))))))
(DATES.MENU.WHENSELECTEDFN
(LAMBDA (ITEM MENU MB) (* fsg "28-Jul-86 14:57")
(COND
((OR (EQ MB 'LEFT)
(EQ MB 'MIDDLE))
(DATES.MENU.APPLY ITEM MENU)))))
(DATES.SET
(LAMBDA (PROPERTY VALUE)
(WINDOWPROP (CREATEW)
PROPERTY VALUE)
VALUE))
(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)))))
(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))))))
(FINDMONTH
(LAMBDA (OLDDATE VERSION) (* shw: " 1-Jul-85 11:38")
(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))))
(FINDTIME
(LAMBDA (OLDDATE VERSION) (* shw: "24-Jul-85 15:39")
(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))))))))
(FINDYEAR
(LAMBDA (OLDDATE VERSION) (* shw: " 1-Jul-85 11:31")
(if (EQ VERSION 'ABBREV)
then (MKATOM (SUBSTRING OLDDATE 8 9))
else (MKATOM (CONCAT "19" (SUBSTRING OLDDATE 8 9))))))
(NUMP
(LAMBDA (N) (* edited: " 4-Apr-86 17:55")
(* changed)
(NOT (NULL (NUMBERP (MKATOM N))))))
(WHICHDATE
(LAMBDA (VAR1 VAR2 YEAR OLDDATE VERSION) (* edited " 1-Jan-00 00:00")
(* * comment)
(PROG (DIVIDER)
(SETQ DIVIDER (if (EQ VERSION 'ABBREV)
then "/"
else " "))
(RETURN (MKATOM (CONCAT (APPLY VAR1 (LIST OLDDATE VERSION))
DIVIDER
(APPLY VAR2 (LIST OLDDATE VERSION))
DIVIDER
(APPLY YEAR (LIST OLDDATE VERSION))))))))
)
[DECLARE: EVAL@COMPILE
(RECORD DATEOBJ (DATESTRING DISPLAY.DATE TEMPLATE.DATE))
(DATATYPE STREAM ( (* First 4 words are fixed for BIN, BOUT opcodes.
Length of whole datatype is multiple of 4, so
quad-aligned)
(COFFSET WORD) (* Offset in CPPTR of next bin or bout)
(CBUFSIZE WORD) (* Offset past last byte in that buffer)
(BINABLE FLAG) (* BIN punts unless this bit on)
(BOUTABLE FLAG) (* BOUT punts unless this bit on)
(EXTENDABLE FLAG) (* BOUT punts when COFFSET ge CBUFFSIZE unless this
bit set and COFFSET lt 512)
(NIL BITS 5)
(CBUFPTR POINTER) (* Pointer to current buffer)
(NONDEFAULTDATEFLG FLAG)
(REVALIDATEFLG FLAG)
(MULTIBUFFERHINT FLAG) (* True if stream likes to read and write more than
one buffer at a time)
(USERCLOSEABLE FLAG) (* Can be closed by CLOSEF;
NIL for terminal, dribble...)
(USERVISIBLE FLAG) (* Listed by OPENP; NIL for terminal, dribble ...)
(ACCESSBITS BITS 3) (* What kind of access file is open for
(read, write, append))
(FULLFILENAME POINTER) (* Name by which file is known to user)
(DEVICE POINTER) (* FDEV of this guy)
(VALIDATION POINTER) (* A number somehow identifying file, used to
determine if file has changed in our absence)
(EPAGE WORD)
(EOFFSET WORD) (* Page, byte offset of eof)
(* Following are device-specific fields)
(F1 POINTER)
(F2 POINTER)
(F3 POINTER)
(F4 POINTER)
(F5 POINTER)
(FW6 WORD)
(FW7 WORD) (* Following only filled in for open streams)
(BYTESIZE BYTE)
(BUFFS POINTER)
(CPAGE WORD)
(FW8 WORD)
(MAXBUFFERS WORD)
(CHARPOSITION WORD) (* Used by POSITION etc.)
(DIRTYBITS WORD)
(LINELENGTH WORD)
(EOLCONVENTION BITS 2) (* End-of-line convention)
(CBUFDIRTY FLAG)
(NIL BITS 5)
(OUTCHARFN POINTER)
(ENDOFSTREAMOP POINTER) (* For use of applications programs, not devices)
(OTHERPROPS POINTER)
(IMAGEOPS POINTER) (* Image operations vector)
(IMAGEDATA POINTER) (* Image instance variables--format depends on
IMAGEOPS value)
(EXTRASTREAMOP POINTER)
(STRMBINFN POINTER) (* Either the BIN fn from the FDEV, or a trap)
(STRMBOUTFN POINTER) (* Either the BIN fn from the FDEV, or a trap)
(CBUFMAXSIZE WORD)
(FW9 WORD)
(F10 POINTER) (* the current character set for this stream.
gbn 4-2-85)
(CHARSET BYTE))
(BLOCKRECORD STREAM ((NIL 2 WORD)
(UCODEFLAGS BYTE)
(NIL POINTER)))
(ACCESSFNS STREAM ((ACCESS \GETACCESS \SETACCESS)
(FULLNAME (OR (fetch (STREAM FULLFILENAME) of DATUM)
DATUM))
(NAMEDP (AND (fetch (STREAM FULLFILENAME) of DATUM)
T))))
(SYNONYM CBUFPTR (CPPTR))
USERCLOSEABLE ← T USERVISIBLE ← T ACCESSBITS ← NoBits BUFFS ← NIL BYTESIZE ← 8
CBUFPTR ← NIL MAXBUFFERS ←(PROGN (DECLARE (GLOBALVARS
\STREAM.DEFAULT.MAXBUFFERS))
\STREAM.DEFAULT.MAXBUFFERS)
CHARPOSITION ← 0 LINELENGTH ←(PROGN (DECLARE (GLOBALVARS FILELINELENGTH))
FILELINELENGTH)
OUTCHARFN ←(FUNCTION \FILEOUTCHARFN)
ENDOFSTREAMOP ←(FUNCTION \EOSERROR)
IMAGEOPS ← \NOIMAGEOPS EOLCONVENTION ←(SELECTQ (SYSTEMTYPE)
(D CR.EOLC)
(VAX LF.EOLC)
(JERICHO CRLF.EOLC)
CR.EOLC)
STRMBINFN ←(FUNCTION \STREAM.NOT.OPEN)
STRMBOUTFN ←(FUNCTION \STREAM.NOT.OPEN))
(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))
]
(/DECLAREDATATYPE 'STREAM
'(WORD WORD FLAG FLAG FLAG (BITS 5)
POINTER FLAG FLAG FLAG FLAG FLAG (BITS 3)
POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER
WORD WORD BYTE POINTER WORD WORD WORD WORD WORD WORD (BITS 2)
FLAG
(BITS 5)
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD
POINTER BYTE)
'((STREAM 0 (BITS . 15))
(STREAM 1 (BITS . 15))
(STREAM 2 (FLAGBITS . 0))
(STREAM 2 (FLAGBITS . 16))
(STREAM 2 (FLAGBITS . 32))
(STREAM 2 (BITS . 52))
(STREAM 2 POINTER)
(STREAM 4 (FLAGBITS . 0))
(STREAM 4 (FLAGBITS . 16))
(STREAM 4 (FLAGBITS . 32))
(STREAM 4 (FLAGBITS . 48))
(STREAM 4 (FLAGBITS . 64))
(STREAM 4 (BITS . 82))
(STREAM 4 POINTER)
(STREAM 6 POINTER)
(STREAM 8 POINTER)
(STREAM 10 (BITS . 15))
(STREAM 11 (BITS . 15))
(STREAM 12 POINTER)
(STREAM 14 POINTER)
(STREAM 16 POINTER)
(STREAM 18 POINTER)
(STREAM 20 POINTER)
(STREAM 22 (BITS . 15))
(STREAM 23 (BITS . 15))
(STREAM 20 (BITS . 7))
(STREAM 24 POINTER)
(STREAM 26 (BITS . 15))
(STREAM 27 (BITS . 15))
(STREAM 28 (BITS . 15))
(STREAM 29 (BITS . 15))
(STREAM 30 (BITS . 15))
(STREAM 31 (BITS . 15))
(STREAM 24 (BITS . 1))
(STREAM 24 (FLAGBITS . 32))
(STREAM 24 (BITS . 52))
(STREAM 32 POINTER)
(STREAM 34 POINTER)
(STREAM 36 POINTER)
(STREAM 38 POINTER)
(STREAM 40 POINTER)
(STREAM 42 POINTER)
(STREAM 44 POINTER)
(STREAM 46 POINTER)
(STREAM 48 (BITS . 15))
(STREAM 49 (BITS . 15))
(STREAM 50 POINTER)
(STREAM 50 (BITS . 7)))
'52)
(/DECLAREDATATYPE 'FONTCLASS
'(BYTE POINTER POINTER POINTER POINTER POINTER)
'((FONTCLASS 0 (BITS . 7))
(FONTCLASS 0 POINTER)
(FONTCLASS 2 POINTER)
(FONTCLASS 4 POINTER)
(FONTCLASS 6 POINTER)
(FONTCLASS 8 POINTER))
'10)
(PUTPROPS DATE COPYRIGHT ("Leland Stanford Junior University" 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (850 12872 (DATEOBJ 862 . 2359) (DATEOBJP 2363 . 2736) (DATE.DISPLAYFN 2740 . 3015) (
DATE.IMAGEBOXFN 3019 . 3575) (CURRENT.DISPLAY.FONT 3579 . 4284) (DATE.PUTFN 4288 . 4541) (DATE.GETFN
4545 . 4956) (DATE.BUTTONEVENTINFN 4960 . 6275) (DATES.TEMPLATE 6279 . 7439) (AMPM 7443 . 7615) (
DATES.MENU.APPLY 7619 . 8538) (DATES.MENU.WHENSELECTEDFN 8542 . 8780) (DATES.SET 8784 . 8895) (FINDDAY
8899 . 9154) (FINDHOUR 9158 . 9662) (FINDMONTH 9666 . 10427) (FINDTIME 10431 . 11846) (FINDYEAR 11850
. 12124) (NUMP 12128 . 12368) (WHICHDATE 12372 . 12869)))))
STOP