(FILECREATED "20-Feb-87 01:37:19" {FIREFS:CS:UNIV% ROCHESTER}<KOOMEN>LISP>DATEFORMAT-EDITOR.;7 19378
changes to: (FNS DATEFORMAT-EDITOR-PUT-STATE DATEFORMAT-EDITOR-GET-STATE \DFE-OUTDATE)
(VARS DATEFORMAT-EDITORCOMS $$DATEFORMAT-EDITOR-ITEMS)
previous date: "12-Feb-87 17:01:38" {FIREFS:CS:UNIV% ROCHESTER}<KOOMEN>LISP>DATEFORMAT-EDITOR.;5
)
(* Copyright (c) 1987 by Johannes A. G. M. Koomen. All rights reserved.)
(PRETTYCOMPRINT DATEFORMAT-EDITORCOMS)
(RPAQQ DATEFORMAT-EDITORCOMS ((* ;;;
"This system provides a facility for editing date formats as described in section 12.5 of the Interlisp-D manual, Koto version. User entry point is the function EDIT-DATEFORMAT. Editing is accomplished using a FREEMENU. Items displayed in this menu are stored on DATEFORMAT-EDITOR-ITEMS. Call (GET-DATEFORMAT-EDITOR T) after changing this variable. Input to EDIT-DATEFORMAT is either NIL or a value returned by the DATEFORMAT function. Output is either NIL -- in case editing was aborted -- or another value as returned from the DATEFORMAT function."
)
(FNS EDIT-DATEFORMAT GET-DATEFORMAT-EDITOR DATEFORMAT-EDITOR-STATUS
DATEFORMAT-EDITOR-GET-STATE DATEFORMAT-EDITOR-PUT-STATE
DATEFORMAT-EDITOR-ABORTFN DATEFORMAT-EDITOR-CLOSEFN
DATEFORMAT-EDITOR-QUITFN)
[COMS (* ;;
"Redefine \OUTDATE in the system file IOCHARS to add two new DATEFORMAT options: MONTH.LONG and MONTH.LEADING"
)
(FNS \DFE-OUTDATE)
(P (COND ((CCODEP (QUOTE \DFE-OUTDATE))
(MOVD? (QUOTE \OUTDATE)
(QUOTE \DFE-SAVED-OUTDATE))
(MOVD (QUOTE \DFE-OUTDATE)
(QUOTE \OUTDATE]
(VARS $$DATEFORMAT-EDITOR-ITEMS ($$DATEFORMAT-EDITOR))
(INITVARS (DATEFORMAT-EDITOR-ITEMS (COPY $$DATEFORMAT-EDITOR-ITEMS)))
(FILES (SYSLOAD)
FREEMENU)))
(* ;;;
"This system provides a facility for editing date formats as described in section 12.5 of the Interlisp-D manual, Koto version. User entry point is the function EDIT-DATEFORMAT. Editing is accomplished using a FREEMENU. Items displayed in this menu are stored on DATEFORMAT-EDITOR-ITEMS. Call (GET-DATEFORMAT-EDITOR T) after changing this variable. Input to EDIT-DATEFORMAT is either NIL or a value returned by the DATEFORMAT function. Output is either NIL -- in case editing was aborted -- or another value as returned from the DATEFORMAT function."
)
(DEFINEQ
(EDIT-DATEFORMAT
[LAMBDA (DATEFORMAT) (* Koomen "30-Jan-87 23:51")
(* * This system provides a facility for editing date formats as described in section 12.14 of the Interlisp-D
manual, Koto version. Editing is accomplished using a FREEMENU. Items displayed in this menu are stored on
DATEFORMAT-EDITOR-ITEMS. Call (GET-DATEFORMAT-EDITOR T) after changing this variable. Input is either NIL or a
value returned by the DATEFORMAT function. Output is either NIL -- in case editing was aborted -- or another value
as returned from the DATEFORMAT function.)
(PROG ((DFE (GET-DATEFORMAT-EDITOR)))
(DATEFORMAT-EDITOR-PUT-STATE DFE DATEFORMAT)
(OPENW DFE)
(NLSETQ (while (EQ (DATEFORMAT-EDITOR-STATUS DFE)
(QUOTE EDIT))
do (BLOCK)))
(CLOSEW DFE)
(if (EQ (DATEFORMAT-EDITOR-STATUS DFE)
(QUOTE QUIT))
then (RETURN (DATEFORMAT-EDITOR-GET-STATE DFE])
(GET-DATEFORMAT-EDITOR
[LAMBDA (RECOMPUTE?) (* Koomen "12-Feb-87 15:18")
(DECLARE (GLOBALVARS $$DATEFORMAT-EDITOR DATEFORMAT-EDITOR-ITEMS LASTMOUSEX LASTMOUSEY
SCREENHEIGHT SCREENWIDTH))
(PROG (R (DFE $$DATEFORMAT-EDITOR))
(if [OR RECOMPUTE? (NOT (WINDOWP DFE))
(FMEMB (DATEFORMAT-EDITOR-STATUS DFE)
(QUOTE (NIL EDIT]
then (SETQ DFE (FM.FORMATMENU DATEFORMAT-EDITOR-ITEMS))
(SETQ $$DATEFORMAT-EDITOR DFE)
(WINDOWPROP DFE (QUOTE DATEFORMAT-EDITORP)
T)
(WINDOWPROP DFE (QUOTE CLOSEFN)
(FUNCTION DATEFORMAT-EDITOR-CLOSEFN))
(WINDOWPROP DFE (QUOTE SHRINKFN)
(QUOTE DON'T))
(WINDOWPROP DFE (QUOTE RESHAPEFN)
(QUOTE DON'T)))
(SETQ R (WINDOWREGION DFE))
[MOVEW DFE (IMIN LASTMOUSEX (IDIFFERENCE SCREENWIDTH (fetch (REGION WIDTH)
of R)))
(IMIN LASTMOUSEY (IDIFFERENCE SCREENHEIGHT (fetch (REGION HEIGHT)
of R]
(DATEFORMAT-EDITOR-STATUS DFE (QUOTE EDIT))
(RETURN DFE])
(DATEFORMAT-EDITOR-STATUS
[LAMBDA (DFE NEWSTATUS) (* Koomen "30-Jan-87 23:41")
(if NEWSTATUS
then (WINDOWPROP DFE (QUOTE DATEFORMAT-EDITOR-STATUS)
NEWSTATUS)
else (WINDOWPROP DFE (QUOTE DATEFORMAT-EDITOR-STATUS])
(DATEFORMAT-EDITOR-GET-STATE
[LAMBDA (DFE) (* Koomen "20-Feb-87 01:19")
(PROG (FMT (STATE (FM.READSTATE DFE)))
(SELECTQ (LISTGET STATE (QUOTE DATE))
(dd-mon-yy)
(dd/mon/yy (push FMT (QUOTE SLASHES)))
(dd% mon% yy (push FMT (QUOTE SPACES)))
(mon% dd,% yy (push FMT (QUOTE MONTH.LEADING)))
(none (push FMT (QUOTE NO.DATE)))
(SHOULDNT))
(SELECTQ (LISTGET STATE (QUOTE YEAR))
(short)
(long (push FMT (QUOTE YEAR.LONG)))
(SHOULDNT))
(SELECTQ (LISTGET STATE (QUOTE MONTH))
(alpha-short)
(alpha-long (push FMT (QUOTE MONTH.LONG)))
(numeric (push FMT (QUOTE NUMBER.OF.MONTH)))
(SHOULDNT))
(SELECTQ (LISTGET STATE (QUOTE DAY))
(none)
(long (push FMT (QUOTE DAY.OF.WEEK)))
(short (push FMT (QUOTE DAY.OF.WEEK))
(push FMT (QUOTE DAY.SHORT)))
(SHOULDNT))
(SELECTQ (LISTGET STATE (QUOTE LEADER))
(yes)
(no (push FMT (QUOTE NO.LEADING.SPACES)))
(SHOULDNT))
(SELECTQ (LISTGET STATE (QUOTE TIME))
(hh:mm:ss)
(hh:mm (push FMT (QUOTE NO.SECONDS)))
(none (push FMT (QUOTE NO.TIME)))
(SHOULDNT))
(SELECTQ (LISTGET STATE (QUOTE TIMEZONE))
(no)
(yes (push FMT (QUOTE TIME.ZONE)))
(SHOULDNT))
(RETURN (APPLY (FUNCTION DATEFORMAT)
FMT])
(DATEFORMAT-EDITOR-PUT-STATE
[LAMBDA (DFE DATEFORMAT) (* Koomen "20-Feb-87 01:36")
(for FMT in (if (AND DATEFORMAT (EQ (CAR (LISTP DATEFORMAT))
(QUOTE DATEFORMAT)))
then (CDR DATEFORMAT))
bind (DATE ← (QUOTE dd-mon-yy))
(YEAR ← (QUOTE short))
(MONTH ← (QUOTE alpha-short))
(DAY ← (QUOTE none))
(LEADER ← (QUOTE yes))
(TIME ← (QUOTE hh:mm:ss))
(TIMEZONE ← (QUOTE no))
do (SELECTQ FMT
(NO.DATE (SETQ DATE (QUOTE none)))
(NUMBER.OF.MONTH (SETQ MONTH (QUOTE numeric)))
(MONTH.LEADING (SETQ DATE (QUOTE mon% dd,% yy)))
(MONTH.LONG (SETQ MONTH (QUOTE alpha-long)))
(YEAR.LONG (SETQ YEAR (QUOTE long)))
(SLASHES (SETQ DATE (QUOTE dd/mon/yy)))
(SPACES (SETQ DATE (QUOTE dd% mon% yy)))
(NO.LEADING.SPACES (SETQ LEADER (QUOTE no)))
(NO.TIME (SETQ TIME (QUOTE none)))
(TIME.ZONE (SETQ TIMEZONE (QUOTE yes)))
(NO.SECONDS (SETQ TIME (QUOTE hh:mm)))
[DAY.OF.WEEK (if (NEQ DAY (QUOTE short))
then (SETQ DAY (QUOTE long]
(DAY.SHORT (SETQ DAY (QUOTE short)))
NIL)
finally (for I in (WINDOWPROP DFE (QUOTE FM.ITEMS))
do (SELECTQ (FM.ITEMPROP I (QUOTE ID))
(DATE (if (EQ DATE (FM.ITEMPROP I (QUOTE LABEL)))
then (FM.CHANGESTATE I DFE)))
(YEAR (if (EQ YEAR (FM.ITEMPROP I (QUOTE LABEL)))
then (FM.CHANGESTATE I DFE)))
(MONTH (if (EQ MONTH (FM.ITEMPROP I (QUOTE LABEL)))
then (FM.CHANGESTATE I DFE)))
(DAY (if (EQ DAY (FM.ITEMPROP I (QUOTE LABEL)))
then (FM.CHANGESTATE I DFE)))
(LEADER (if (EQ LEADER (FM.ITEMPROP I (QUOTE LABEL)))
then (FM.CHANGESTATE I DFE)))
(TIME (if (EQ TIME (FM.ITEMPROP I (QUOTE LABEL)))
then (FM.CHANGESTATE I DFE)))
(TIMEZONE (if (EQ TIMEZONE (FM.ITEMPROP I (QUOTE LABEL)))
then (FM.CHANGESTATE I DFE)))
NIL])
(DATEFORMAT-EDITOR-ABORTFN
[LAMBDA (ITEM WINDOW BUTTONS) (* Koomen "30-Jan-87 23:43")
(DATEFORMAT-EDITOR-STATUS WINDOW (QUOTE ABORT])
(DATEFORMAT-EDITOR-CLOSEFN
[LAMBDA (WINDOW) (* Koomen "30-Jan-87 23:42")
(if (EQ (DATEFORMAT-EDITOR-STATUS WINDOW)
(QUOTE EDIT))
then (DATEFORMAT-EDITOR-STATUS WINDOW (QUOTE ABORT])
(DATEFORMAT-EDITOR-QUITFN
[LAMBDA (ITEM WINDOW BUTTONS) (* Koomen "30-Jan-87 23:44")
(DATEFORMAT-EDITOR-STATUS WINDOW (QUOTE QUIT])
)
(* ;;
"Redefine \OUTDATE in the system file IOCHARS to add two new DATEFORMAT options: MONTH.LONG and MONTH.LEADING"
)
(DEFINEQ
(\DFE-OUTDATE
[LAMBDA (UD FORMAT STRING) (* Koomen "20-Feb-87 01:03")
(* bvm: "28-Jun-85 17:23")
(* ;;
"Adapted from \OUTDATE in IOCHARS of 28-Jun-85 21:07:58")
(PROG ((TIME (CDDDR UD))
(SEPR (CHARCODE -))
YEAR SIZE DAY MONTH S N NO.DATE NO.TIME NO.LEADING.SPACES TIME.ZONE TIME.ZONE.LENGTH
YEAR.LENGTH MONTH.LENGTH DAY.LENGTH NO.SECONDS NUMBER.OF.MONTH YEAR.LONG MONTH.LONG
MONTH.LEADING DAY.OF.WEEK DAY.SHORT)
[if (NULL FORMAT)
then NIL
elseif (NEQ (CAR (LISTP FORMAT))
(QUOTE DATEFORMAT))
then (LISPERROR "ILLEGAL ARG" FORMAT)
else (for TOKEN in FORMAT do (SELECTQ TOKEN
(NO.DATE (SETQ NO.DATE T))
(NO.TIME (SETQ NO.TIME T))
(NUMBER.OF.MONTH (SETQ
NUMBER.OF.MONTH T))
(MONTH.LONG (SETQ MONTH.LONG T))
(MONTH.LEADING (SETQ MONTH.LEADING T))
(YEAR.LONG (SETQ YEAR.LONG T))
(SLASHES (SETQ SEPR (CHARCODE
/)))
(SPACES (SETQ SEPR (CHARCODE
SPACE)))
(NO.LEADING.SPACES (SETQ
NO.LEADING.SPACES T))
[TIME.ZONE (SETQ TIME.ZONE
(CDR (ASSOC
\TimeZoneComp
TIME.ZONES]
(NO.SECONDS (SETQ NO.SECONDS T))
(DAY.OF.WEEK (SETQ DAY.OF.WEEK T))
(DAY.SHORT (SETQ DAY.SHORT T))
NIL))
(if MONTH.LEADING
then (SETQ NUMBER.OF.MONTH NIL)
(SETQ SEPR (CHARCODE SPACE]
[SETQ SIZE
(IPLUS (if NO.DATE
then 0
else (SETQ YEAR (CAR UD))
(SETQ MONTH (IPLUS (CADR UD)
1))
(SETQ DAY (CADDR UD))
(IPLUS 2 (SETQ YEAR.LENGTH (if YEAR.LONG
then 4
elseif (IGREATERP YEAR 1999)
then (SETQ YEAR.LONG T)
4
else (SETQ YEAR
(IREMAINDER YEAR 100))
2))
(SETQ DAY.LENGTH (if (AND (OR NO.LEADING.SPACES
MONTH.LEADING)
(ILESSP DAY 10))
then 1
else 2))
(SETQ MONTH.LENGTH
(if NUMBER.OF.MONTH
then (if (AND (OR NO.LEADING.SPACES
MONTH.LEADING)
(ILESSP MONTH 10))
then 1
else 2)
elseif MONTH.LONG
then (SETQ MONTH
(CAR (NTH (QUOTE ("January" "February"
"March"
"April"
"May"
"June"
"July"
"August"
"September"
"October"
"November"
"December"))
MONTH)))
(NCHARS MONTH)
else (SETQ MONTH
(CAR (NTH (QUOTE ("Jan" "Feb" "Mar" "Apr"
"May"
"Jun" "Jul" "Aug"
"Sep"
"Oct" "Nov" "Dec")
)
MONTH)))
3))
(if MONTH.LEADING
then (* ; "Insert a comma")
1
else 0)
(if DAY.OF.WEEK
then [SETQ DAY.OF.WEEK
(CAR (NTH (QUOTE ("Monday" "Tuesday"
"Wednesday"
"Thursday"
"Friday"
"Saturday"
"Sunday"))
(IPLUS (CAR (CDDDDR TIME))
1]
[IPLUS 3 (SETQ DAY.SHORT
(if DAY.SHORT
then (SETQ DAY.OF.WEEK
(SUBSTRING DAY.OF.WEEK
1 3))
3
else (NCHARS DAY.OF.WEEK]
else 0)))
(if NO.TIME
then 0
else (IPLUS (if NO.DATE
then 5
else 6)
(if NO.SECONDS
then 0
else 3)
(if (NULL TIME.ZONE)
then 0
elseif (EQ (SETQ TIME.ZONE.LENGTH (NCHARS
TIME.ZONE))
1)
then 4
else (IPLUS TIME.ZONE.LENGTH 1]
(SETQ S (ALLOCSTRING SIZE (CHARCODE SPACE)))
[if NO.DATE
then (SETQ N 0)
else (if MONTH.LEADING
then (if NUMBER.OF.MONTH
then (PROMPTPRINT MONTH.LENGTH)
(\RPLRIGHT S (SETQ N MONTH.LENGTH)
MONTH MONTH.LENGTH)
else (RPLSTRING S 1 MONTH)
(SETQ N MONTH.LENGTH))
(RPLCHARCODE S (add N 1)
SEPR)
(\RPLRIGHT S (add N (if (AND (OR NO.LEADING.SPACES
MONTH.LEADING)
(ILESSP DAY 10))
then 1
else 2))
DAY 1)
(if MONTH.LEADING
then (RPLCHARCODE S (add N 1)
(CHARCODE ",")))
else (\RPLRIGHT S (SETQ N (if (AND NO.LEADING.SPACES
(ILESSP DAY 10))
then 1
else 2))
DAY 1)
(RPLCHARCODE S (add N 1)
SEPR)
(if NUMBER.OF.MONTH
then (\RPLRIGHT S (add N MONTH.LENGTH)
MONTH MONTH.LENGTH)
else (RPLSTRING S (IPLUS N 1)
MONTH)
(add N MONTH.LENGTH)))
(RPLCHARCODE S (add N 1)
SEPR)
(\RPLRIGHT S (add N YEAR.LENGTH)
YEAR 2)
(if (NOT NO.TIME)
then (add N 1))
(if DAY.OF.WEEK
then (* Day of week at very end in parens)
(RPLCHARCODE S (IPLUS (IDIFFERENCE SIZE DAY.SHORT)
-1)
(CHARCODE "("))
(RPLSTRING S (IDIFFERENCE SIZE DAY.SHORT)
DAY.OF.WEEK)
(RPLCHARCODE S SIZE (CHARCODE ")"]
[if (NOT NO.TIME)
then (\RPLRIGHT S (IPLUS N 2)
(CAR TIME)
2)
(RPLCHARCODE S (IPLUS N 3)
(CHARCODE :))
(\RPLRIGHT S (add N 5)
(CADR TIME)
2)
(if (NOT NO.SECONDS)
then (RPLCHARCODE S (IPLUS N 1)
(CHARCODE :))
(\RPLRIGHT S (add N 3)
(CADDR TIME)
2))
(if TIME.ZONE
then (RPLSTRING S (IPLUS N 2)
TIME.ZONE)
(if (EQ TIME.ZONE.LENGTH 1)
then (* Fill in daylight or standard)
(RPLSTRING S (IPLUS N 3)
(if (CADDDR TIME)
then "DT"
else "ST"]
(RETURN (if STRING
then (SUBSTRING S 1 -1 STRING)
else S])
)
[COND ((CCODEP (QUOTE \DFE-OUTDATE))
(MOVD? (QUOTE \OUTDATE)
(QUOTE \DFE-SAVED-OUTDATE))
(MOVD (QUOTE \DFE-OUTDATE)
(QUOTE \OUTDATE]
(RPAQQ $$DATEFORMAT-EDITOR-ITEMS (((LABEL Quit SELECTEDFN DATEFORMAT-EDITOR-QUITFN MESSAGE
"Stop editing, return current settings"
FONT
(GACHA 10 BOLD))
(LABEL "")
(LABEL Abort SELECTEDFN DATEFORMAT-EDITOR-ABORTFN MESSAGE
"Stop editing, ignore changes, return NIL"
FONT
(GACHA 10 BOLD)))
((TYPE TITLE LABEL ""))
((TYPE TITLE LABEL "DATE:" FONT (GACHA 10 BOLD))
(TYPE NWAY ID DATE LABEL dd-mon-yy)
(LABEL "")
(TYPE NWAY ID DATE LABEL none))
((LABEL " ")
(TYPE NWAY ID DATE LABEL dd/mon/yy)
(LABEL "")
(TYPE NWAY ID DATE LABEL dd% mon% yy)
(LABEL "")
(TYPE NWAY ID DATE LABEL mon% dd,% yy))
((TYPE TITLE LABEL " Year:" FONT (GACHA 10 BOLD))
(TYPE NWAY ID YEAR LABEL short)
(TYPE NWAY ID YEAR LABEL long))
((TYPE TITLE LABEL " Month:" FONT (GACHA 10 BOLD))
(TYPE NWAY ID MONTH LABEL alpha-short)
(TYPE NWAY ID MONTH LABEL alpha-long)
(TYPE NWAY ID MONTH LABEL numeric))
((TYPE TITLE LABEL " Weekday:" FONT (GACHA 10 BOLD))
(TYPE NWAY ID DAY LABEL none)
(TYPE NWAY ID DAY LABEL long)
(TYPE NWAY ID DAY LABEL short))
((TYPE TITLE LABEL " Leading spaces:" FONT (GACHA 10 BOLD))
(TYPE NWAY ID LEADER LABEL yes)
(TYPE NWAY ID LEADER LABEL no))
((TYPE TITLE LABEL "TIME:" FONT (GACHA 10 BOLD))
(TYPE NWAY ID TIME LABEL hh:mm:ss)
(TYPE NWAY ID TIME LABEL hh:mm)
(TYPE NWAY ID TIME LABEL none))
((TYPE TITLE LABEL " Time Zone:" FONT (GACHA 10 BOLD))
(TYPE NWAY ID TIMEZONE LABEL no)
(TYPE NWAY ID TIMEZONE LABEL yes))
(WINDOWPROPS TITLE "Date Format Editor" LEFT 150 BOTTOM 150)))
(RPAQQ $$DATEFORMAT-EDITOR NIL)
(RPAQ? DATEFORMAT-EDITOR-ITEMS (COPY $$DATEFORMAT-EDITOR-ITEMS))
(FILESLOAD (SYSLOAD)
FREEMENU)
(PUTPROPS DATEFORMAT-EDITOR COPYRIGHT ("Johannes A. G. M. Koomen" 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2430 9850 (EDIT-DATEFORMAT 2440 . 3501) (GET-DATEFORMAT-EDITOR 3503 . 4732) (
DATEFORMAT-EDITOR-STATUS 4734 . 5038) (DATEFORMAT-EDITOR-GET-STATE 5040 . 6757) (
DATEFORMAT-EDITOR-PUT-STATE 6759 . 9208) (DATEFORMAT-EDITOR-ABORTFN 9210 . 9394) (
DATEFORMAT-EDITOR-CLOSEFN 9396 . 9664) (DATEFORMAT-EDITOR-QUITFN 9666 . 9848)) (9979 17135 (
\DFE-OUTDATE 9989 . 17133)))))
STOP