Rewrite code for deciding 'Good morning', 'Good evening' 'You're working late' Y2K (#1208)

sources/HIST

@@ -1,16 +1,13 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
-
(FILECREATED "10-Jul-91 12:07:43" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>HIST.;3|
 152184 
 
-      |changes| |to:|  (VARS HISTCOMS)
+
(FILECREATED "19-Apr-2023 18:58:13" |{DSK}<home>larry>il>medley>sources>HIST.;6|
 152088 
 
-      |previous| |date:| "16-May-90 18:10:04" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>HIST.;2|)
+      :EDIT-BY "lmm"
 
+      :CHANGES-TO (FNS GREET0)
+
+      :PREVIOUS-DATE "19-Mar-2023 10:09:08" |{DSK}<home>larry>il>medley>sources>HIST.;1|)
 
-; Copyright (c) 1978, 1984, 1985, 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
-; The following program was created in 1978 but has not been published
-; within the meaning of the copyright law, is furnished under license,
-; and may not be used, copied and/or disclosed except in accordance
-; with the terms of said license.
 
 (PRETTYCOMPRINT HISTCOMS)
 
@@ -2527,7 +2524,7 @@ this sysout is initialized for user " T)
 )
 
 (ADDTOVAR SYSTEMINITVARS
 (LISPXHISTORY NIL 0 100 100)
-                             (GREETHIST))
+                         (GREETHIST))
 (DECLARE\: DONTEVAL@LOAD DOCOPY 
 
 (RPAQQ \#REDOCNT
 3)
@@ -2656,8 +2653,8 @@ this sysout is initialized for user " T)
 
 (ADDTOVAR HISTORYSAVEFORMS
 )
 
-(ADDTOVAR LISPXCOMS
  |...| ?? FIX FORGET NAME ORIGINAL REDO REPEAT RETRY UNDO USE |fix| |forget|
-                          |name| |redo| |repeat| |retry| |undo| |use|)
+(ADDTOVAR LISPXCOMS
  |...| ?? FIX FORGET NAME ORIGINAL REDO REPEAT RETRY UNDO USE |fix| |forget| 
+                      |name| |redo| |repeat| |retry| |undo| |use|)
 
 (ADDTOVAR SYSTATS

           (LISPXSTATS LISPX INPUTS)
@@ -2703,27 +2700,27 @@ this sysout is initialized for user " T)
 (ADDTOVAR NOCLEARSTKLST
 )
 
 (APPENDTOVAR AFTERSYSOUTFORMS
 (COND ((LISTP SYSOUTGAG)
-                                         (EVAL SYSOUTGAG))
-                                        (SYSOUTGAG)
-                                        ((OR (NULL USERNAME)
-                                             (EQ USERNAME (USERNAME NIL T)))
-                                         (TERPRI T)
-                                         (PRIN1 HERALDSTRING T)
-                                         (TERPRI T)
-                                         (TERPRI T)
-                                         (GREET0)
-                                         (TERPRI T))
-                                        (T (LISPXPRIN1 '"****ATTENTION USER " T)
-                                           (LISPXPRIN1 (USERNAME)
-                                                  T)
-                                           (LISPXPRIN1 '":
+                                     (EVAL SYSOUTGAG))
+                                    (SYSOUTGAG)
+                                    ((OR (NULL USERNAME)
+                                         (EQ USERNAME (USERNAME NIL T)))
+                                     (TERPRI T)
+                                     (PRIN1 HERALDSTRING T)
+                                     (TERPRI T)
+                                     (TERPRI T)
+                                     (GREET0)
+                                     (TERPRI T))
+                                    (T (LISPXPRIN1 '"****ATTENTION USER " T)
+                                       (LISPXPRIN1 (USERNAME)
+                                              T)
+                                       (LISPXPRIN1 '":
 this sysout is initialized for user " T)
-                                           (LISPXPRIN1 USERNAME T)
-                                           (LISPXPRIN1 '".
+                                       (LISPXPRIN1 USERNAME T)
+                                       (LISPXPRIN1 '".
 " T)
-                                           (LISPXPRIN1 '"To reinitialize, type GREET()
+                                       (LISPXPRIN1 '"To reinitialize, type GREET()
 " T)))
-                                  (SETINITIALS))
+                              (SETINITIALS))
 
 (MAPC SYSTATS (FUNCTION (LAMBDA (X)
                           (AND (LISTP X)
@@ -2756,46 +2753,48 @@ this sysout is initialized for user " T)
                       (return t)))
         (printout t "error during GREET..." t))))
 
-(greet0

-  (lambda nil
                                                (* |lmm| "28-DEC-82 08:49")

-    (cond
-       (greetdates
-        (lispxprin1

-         (prog ((date (date))
-                hour tem digit)
-               (return (or (and (fixp (setq digit (nthchar date -1)))
-                                (or (and (evenp (lrsh digit 1))
-                                         (stringp (setq tem
-                                                   (cdr (sassoc (u-case (substring date 1 6))
-                                                               greetdates)))))
-                                    (and (evenp digit)
-                                         (fixp (setq hour (subatom date 11 12)))
-                                         (cond
-                                            ((and firstname (ilessp hour 6))
+(GREET0

+  (LAMBDA NIL
                                               (* \; "Edited 19-Apr-2023 18:55 by lmm")


+                                                            (* \; "Edited 19-Mar-2023 09:58 by lmm")

+                                                             (* |lmm| "28-DEC-82 08:49")

+    (COND
+       (GREETDATES (LISPXPRIN1
 (CL:MULTIPLE-VALUE-BIND
+                                (SECONDS MINUTES HOUR DAY MONTH YEAR)
+                                (CL:GET-DECODED-TIME)
+                                (OR (AND (EVENP (LRSH SECONDS 1))
+                                         (CDR (SASSOC (CL:FORMAT NIL "~2D-~A" DAY
+                                                             (CL:NTH MONTH
+                                                                    '("JAN" "FEB" "MAR" "APR" "MAY" 
+                                                                            "JUN" "JUL" "AUG" "SEP" 
+                                                                            "OCT" "NOV" "DEC")))
+                                                     GREETDATES)))
+                                    (AND (EVENP SECONDS)
+                                         (COND
+                                            ((AND FIRSTNAME (ILESSP HOUR 6))
                                              '"You're working late tonight")
-                                            ((ilessp hour 12)
+                                            ((ILESSP HOUR 12)
                                              '"Good morning")
-                                            ((ilessp hour 18)
+                                            ((ILESSP HOUR 18)
                                              '"Good afternoon")
-                                            (t '"Good evening")))
-                                    (and (evenp digit 3)
-                                         "Hello")))
-                           '"Hi")))
-         t)
-        (cond
-           (firstname (lispxprin1
 '", " t)
-                  (lispxprin1
 firstname t)))
-        (lispxprin1
 "." t)
-        (lispxterpri
 t)))))
+                                            (T '"Good evening")))
+                                    (AND (EVENP SECONDS 3)
+                                         "Hello")
+                                    '"Hi"))
+                          T)
+              (COND
+                 (FIRSTNAME (LISPXPRIN1
 '", " T)
+                        (LISPXPRIN1
 FIRSTNAME T)))
+              (LISPXPRIN1
 "." T)
+              (LISPXTERPRI
 T)))))
 )
 
 (ADDTOVAR PREGREETFORMS
 (DREMOVE GREETFORM RESETFORMS)
-                            (SETQ CONSOLETIME (SETQ CPUTIME (SETQ EDITIME 0)))
-                            (SETQ CONSOLETIME0 (CLOCK 0))
-                            (SETQ CPUTIME0 (CLOCK 2)))
+                        (SETQ CONSOLETIME (SETQ CPUTIME (SETQ EDITIME 0)))
+                        (SETQ CONSOLETIME0 (CLOCK 0))
+                        (SETQ CPUTIME0 (CLOCK 2)))
 
 (ADDTOVAR POSTGREETFORMS
 (SETINITIALS)
-                             (AND EDITCHARACTERS (APPLY 'SETTERMCHARS EDITCHARACTERS)))
+                         (AND EDITCHARACTERS (APPLY 'SETTERMCHARS EDITCHARACTERS)))
 (DECLARE\: DONTEVAL@LOAD DOCOPY 
 
 (RPAQQ GREETHIST
 NIL)
@@ -2803,21 +2802,21 @@ this sysout is initialized for user " T)
 (RPAQQ SYSTEMTYPE
 NIL)
 
 (RPAQQ GREETFORM
 (LISPXEVAL '(GREET)
-                            '_))
+                        '_))
 
 (RPAQQ CUTEFLG
 NIL)
 
 (RPAQQ GREETDATES
 ((" 1-JAN" . "Happy new year")
-                       ("12-FEB" . "Happy Lincoln's birthday")
-                       ("14-FEB" . "Happy Valentine's day")
-                       ("22-FEB" . "Happy Washington's birthday")
-                       ("15-MAR" . "Beware the Ides of March")
-                       ("17-MAR" . "Happy St. Patrick's day")
-                       ("18-MAY" . "It's Victoria Day")
-                       (" 1-JUL" . "It's Canada Day")
-                       ("31-OCT" . "Trick or Treat")
-                       (" 5-NOV" . "<boom> it's Guy Fawkes day")
-                       ("25-DEC" . "Merry Christmas")))
+                   ("12-FEB" . "Happy Lincoln's birthday")
+                   ("14-FEB" . "Happy Valentine's day")
+                   ("22-FEB" . "Happy Washington's birthday")
+                   ("15-MAR" . "Beware the Ides of March")
+                   ("17-MAR" . "Happy St. Patrick's day")
+                   ("18-MAY" . "It's Victoria Day")
+                   (" 1-JUL" . "It's Canada Day")
+                   ("31-OCT" . "Trick or Treat")
+                   (" 5-NOV" . "<boom> it's Guy Fawkes day")
+                   ("25-DEC" . "Merry Christmas")))
 
 (RPAQQ USERNAME
 NIL)
 
@@ -2837,11 +2836,11 @@ this sysout is initialized for user " T)
 
 
 (ADDTOVAR BEFOREMAKESYSFORMS
 (SETQ RESETFORMS (CONS GREETFORM RESETFORMS))
-                                 (SETQ MAKESYSDATE (DATE)))
+                             (SETQ MAKESYSDATE (DATE)))
 
 
 (ADDTOVAR AFTERMAKESYSFORMS
 (LISPXEVAL '(GREET)
-                                       '_))
+                                   '_))
 )
 (DEFINEQ
 
@@ -3038,21 +3037,20 @@ this sysout is initialized for user " T)
 
 (ADDTOVAR LAMA
 )
 )
-(PUTPROPS HIST COPYRIGHT ("Venue & Xerox Corporation" T 1978 1984 1985 1986 1987 1988 1990 1991))
 (DECLARE\: DONTCOPY
-  (FILEMAP (NIL (14585 21330 (PRINTHISTORY 14595 . 16385) (ENTRY# 16387 . 16722) (PRINTHISTORY1 16724 . 
-19893) (PRINTHISTORY2 19895 . 21328)) (21331 129761 (EVALQT 21341 . 22141) (ENTEREVALQT 22143 . 22698)
- (USEREXEC 22700 . 23335) (LISPXREAD 23337 . 25140) (LISPXREADBUF 25142 . 27368) (LISPXREADP 27370 . 
-27919) (LISPXUNREAD 27921 . 28214) (LISPX 28216 . 63911) (LISPX/ 63913 . 65367) (LISPX/1 65369 . 70655
-) (LISPXEVAL 70657 . 71281) (LISPXSTOREVALUE 71283 . 71537) (HISTORYSAVE 71539 . 78823) (LISPXFIND 
-78825 . 86260) (LISPXGETINPUT 86262 . 86475) (REMEMBER 86477 . 86671) (GETEXPRESSIONFROMEVENTSPEC 
-86673 . 88783) (LISPXFIND0 88785 . 93059) (LISPXFIND1 93061 . 93489) (HISTORYFIND 93491 . 99065) (
-HISTORYFIND1 99067 . 102512) (HISTORYMATCH 102514 . 102589) (VALUEOF 102591 . 103616) (VALUOF 103618
- . 104508) (VALUOF-EVENT 104510 . 104915) (LISPXUSE 104917 . 111336) (LISPXUSE0 111338 . 114064) (
-LISPXUSE1 114066 . 115691) (LISPXSUBST 115693 . 116113) (LISPXUSEC 116115 . 124356) (LISPXFIX 124358
- . 125208) (CHANGESLICE 125210 . 127057) (LISPXSTATE 127059 . 128153) (LISPXTYPEAHEAD 128155 . 129759)
-) (137892 140620 (GREET 137902 . 139043) (GREET0 139045 . 140618)) (142290 149466 (LISPXPRINT 142300
- . 142864) (LISPXPRIN1 142866 . 143750) (LISPXPRIN2 143752 . 144694) (LISPXPRINTDEF 144696 . 145250) (
-LISPXPRINTDEF0 145252 . 145615) (LISPXSPACES 145617 . 146303) (LISPXTERPRI 146305 . 146930) (LISPXTAB 
-146932 . 147490) (USERLISPXPRINT 147492 . 148892) (LISPXPUT 148894 . 149464)))))
+  (FILEMAP (NIL (14244 20989 (PRINTHISTORY 14254 . 16044) (ENTRY# 16046 . 16381) (PRINTHISTORY1 16383 . 
+19552) (PRINTHISTORY2 19554 . 20987)) (20990 129420 (EVALQT 21000 . 21800) (ENTEREVALQT 21802 . 22357)
+ (USEREXEC 22359 . 22994) (LISPXREAD 22996 . 24799) (LISPXREADBUF 24801 . 27027) (LISPXREADP 27029 . 
+27578) (LISPXUNREAD 27580 . 27873) (LISPX 27875 . 63570) (LISPX/ 63572 . 65026) (LISPX/1 65028 . 70314
+) (LISPXEVAL 70316 . 70940) (LISPXSTOREVALUE 70942 . 71196) (HISTORYSAVE 71198 . 78482) (LISPXFIND 
+78484 . 85919) (LISPXGETINPUT 85921 . 86134) (REMEMBER 86136 . 86330) (GETEXPRESSIONFROMEVENTSPEC 
+86332 . 88442) (LISPXFIND0 88444 . 92718) (LISPXFIND1 92720 . 93148) (HISTORYFIND 93150 . 98724) (
+HISTORYFIND1 98726 . 102171) (HISTORYMATCH 102173 . 102248) (VALUEOF 102250 . 103275) (VALUOF 103277
+ . 104167) (VALUOF-EVENT 104169 . 104574) (LISPXUSE 104576 . 110995) (LISPXUSE0 110997 . 113723) (
+LISPXUSE1 113725 . 115350) (LISPXSUBST 115352 . 115772) (LISPXUSEC 115774 . 124015) (LISPXFIX 124017
+ . 124867) (CHANGESLICE 124869 . 126716) (LISPXSTATE 126718 . 127812) (LISPXTYPEAHEAD 127814 . 129418)
+) (137472 140690 (GREET 137482 . 138623) (GREET0 138625 . 140688)) (142292 149468 (LISPXPRINT 142302
+ . 142866) (LISPXPRIN1 142868 . 143752) (LISPXPRIN2 143754 . 144696) (LISPXPRINTDEF 144698 . 145252) (
+LISPXPRINTDEF0 145254 . 145617) (LISPXSPACES 145619 . 146305) (LISPXTERPRI 146307 . 146932) (LISPXTAB 
+146934 . 147492) (USERLISPXPRINT 147494 . 148894) (LISPXPUT 148896 . 149466)))))
 STOP