Remove explicit old versions from cloned repo (#392)
it took a long time to figure out how to restore old versions, using the './scripts/restore-versions file'. Now that it's there and tested it should be ok to remove them from new 'git clone' of medley
This commit is contained in:
Larry Masinter
GitHub
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
@@ -1,335 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "29-Dec-98 08:41:59" {DSK}<project>medley2.0>lispusers>COMPAREDIRECTORIES.;6 21429
|
||||
|
||||
changes to%: (FNS COMPAREDIRS.FORMATLINE COMPAREDIRECTORIES)
|
||||
|
||||
previous date%: "29-Dec-98 06:39:50" {DSK}<project>medley2.0>lispusers>COMPAREDIRECTORIES.;3)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998 by Venue & Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COMPAREDIRECTORIESCOMS)
|
||||
|
||||
(RPAQQ COMPAREDIRECTORIESCOMS (
|
||||
(* ;; "Compare the contents to two directories.")
|
||||
|
||||
(FNS COMPAREDIRECTORIES COMPAREDIRS.FORMATLINE
|
||||
COMPAREDIRECTORIES.NEWPAGEFN COMPARE-DIRECTORIES)
|
||||
|
||||
(* ;; "look for compiled files older than the sources")
|
||||
|
||||
(FNS FIND-UNCOMPILED-FILES)))
|
||||
|
||||
|
||||
|
||||
(* ;; "Compare the contents to two directories.")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(COMPAREDIRECTORIES
|
||||
[LAMBDA (FROMDIR TODIR SHOW=FILESTOO USELISPFILEDATE FILEPATTERN LISTINGFILE EXTENSIONSTOAVOID)
|
||||
(* ; "Edited 29-Dec-98 08:39 by rmk:")
|
||||
|
||||
(* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW=FILESTOO, then files that are the same are also listed. LISTINGFILE is either a filename for an image stream, or NIL to go to the display.")
|
||||
|
||||
(LET [(LISTINGSTREAM (COND
|
||||
[LISTINGFILE (OPENIMAGESTREAM LISTINGFILE NIL '(LANDSCAPE T]
|
||||
(T NIL)))
|
||||
(TO-FILES (for FILE in [DIRECTORY (PACKFILENAME.STRING 'BODY TODIR 'BODY
|
||||
(OR FILEPATTERN '*.*;]
|
||||
collect (PACKFILENAME.STRING 'VERSION NIL 'BODY FILE]
|
||||
(COND
|
||||
(LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN)
|
||||
[STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT FROMDIR " vs " TODIR)
|
||||
(CONCAT "as of " (DATE]
|
||||
(COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM)))
|
||||
[for FILENAME infiles (PACKFILENAME.STRING 'BODY FROMDIR 'BODY (OR FILEPATTERN
|
||||
'*.*;))
|
||||
bind DT1 DT2 TON SHORT-FROM SHORT-TO
|
||||
when [PROGN [SETQ TO-FILES (CL:DELETE (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL
|
||||
'DEVICE NIL 'VERSION NIL 'BODY FILENAME)
|
||||
TO-FILES :TEST #'(LAMBDA (ITEM SEQUENCE-ITEM)
|
||||
(STRING-EQUAL
|
||||
ITEM
|
||||
(PACKFILENAME.STRING
|
||||
'HOST NIL 'DIRECTORY NIL
|
||||
'DEVICE NIL 'VERSION NIL
|
||||
'BODY SEQUENCE-ITEM]
|
||||
(NOT (CL:MEMBER (UNPACKFILENAME.STRING FILENAME 'EXTENSION)
|
||||
EXTENSIONSTOAVOID :TEST #'STRING-EQUAL]
|
||||
do (AND NIL (PRINTOUT T FILENAME T))
|
||||
(COND
|
||||
[[SETQ TON (INFILEP (PACKFILENAME.STRING 'DIRECTORY TODIR 'VERSION NIL
|
||||
'BODY
|
||||
(SETQ SHORT-FROM (PACKFILENAME.STRING 'HOST NIL
|
||||
'DIRECTORY NIL 'DEVICE NIL
|
||||
'BODY FILENAME]
|
||||
(SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'DEVICE NIL
|
||||
'BODY TON))
|
||||
[IF (AND USELISPFILEDATE (SETQ DT1 (FILEDATE FILENAME))
|
||||
(SETQ DT2 (FILEDATE TON)))
|
||||
THEN (SETQ DT1 (IDATE DT1))
|
||||
(SETQ DT2 (IDATE DT2))
|
||||
ELSE (SETQ DT1 (GETFILEINFO FILENAME 'ICREATIONDATE))
|
||||
(SETQ DT2 (GETFILEINFO TON 'ICREATIONDATE]
|
||||
(COND
|
||||
[(EQUAL DT1 DT2) (* ; "same")
|
||||
(COND
|
||||
(SHOW=FILESTOO (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM ""
|
||||
(GDATE DT1)
|
||||
"=="
|
||||
(GDATE DT2)
|
||||
SHORT-TO ""]
|
||||
(T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO
|
||||
FILENAME
|
||||
'AUTHOR)
|
||||
(GDATE DT1)
|
||||
(COND
|
||||
((LESSP DT1 DT2)
|
||||
"< ")
|
||||
(T " >"))
|
||||
(GDATE DT2)
|
||||
SHORT-TO
|
||||
(GETFILEINFO TON 'AUTHOR]
|
||||
(T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO
|
||||
FILENAME
|
||||
'AUTHOR)
|
||||
(GETFILEINFO FILENAME 'CREATIONDATE)
|
||||
"**" NIL ""]
|
||||
[bind SHORT-TO DT2 for FILENAME in TO-FILES
|
||||
when (NOT (CL:MEMBER (UNPACKFILENAME.STRING FILENAME 'EXTENSION)
|
||||
EXTENSIONSTOAVOID :TEST #'STRING-EQUAL))
|
||||
do (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'DEVICE NIL
|
||||
'BODY FILENAME))
|
||||
(SETQ DT2 (GETFILEINFO FILENAME 'ICREATIONDATE))
|
||||
(COMPAREDIRS.FORMATLINE LISTINGSTREAM "" NIL NIL "**" (GDATE DT2)
|
||||
SHORT-TO
|
||||
(GETFILEINFO FILENAME 'AUTHOR]
|
||||
(AND LISTINGSTREAM (CLOSEF LISTINGSTREAM])
|
||||
|
||||
(COMPAREDIRS.FORMATLINE
|
||||
[LAMBDA (STREAM FROM FROMAUTHOR FDATE COMP TDATE TO TOAUTHOR)
|
||||
(* ; "Edited 29-Dec-98 08:41 by rmk:")
|
||||
|
||||
(* ;; "Format one line of the directory comparison listing. If FROMAUTHOR or TOAUTHOR are non-NIL, list the author in parens; otherwise omit it.")
|
||||
|
||||
(COND
|
||||
(STREAM (* ;
|
||||
"It's an image stream, where TAB doesn't work right.")
|
||||
(LET* [(COMPFONT (FONTCREATE 'MODERN 8 'BOLD NIL STREAM))
|
||||
(MAINFONT (FONTCREATE 'MODERN 8 NIL NIL STREAM))
|
||||
(SPACEWIDTH (CHARWIDTH (CHARCODE SPACE)
|
||||
STREAM))
|
||||
(LEFTMARGIN (DSPLEFTMARGIN NIL STREAM))
|
||||
(RIGHTMARGIN (DSPRIGHTMARGIN NIL STREAM))
|
||||
(CENTER (IQUOTIENT (+ LEFTMARGIN RIGHTMARGIN)
|
||||
2))
|
||||
(COMPWIDTH (IQUOTIENT (IMAX (STRINGWIDTH " >" COMPFONT)
|
||||
(STRINGWIDTH "< " COMPFONT)
|
||||
(STRINGWIDTH "==" COMPFONT)
|
||||
(STRINGWIDTH "**" COMPFONT))
|
||||
2))
|
||||
(LEFTSIDE (- CENTER 353 COMPWIDTH))
|
||||
(RIGHTSIDE (+ CENTER COMPWIDTH 353))
|
||||
(FROM-STRING (COND
|
||||
(FROM (CL:FORMAT NIL "~A (~A; ~A)" FROM FROMAUTHOR FDATE))
|
||||
(T "")))
|
||||
(TO-STRING (COND
|
||||
(TO (CL:FORMAT NIL "~A (~A; ~A)" TO TOAUTHOR TDATE))
|
||||
(T ""]
|
||||
(DSPFONT COMPFONT STREAM)
|
||||
(DSPXPOSITION (- CENTER (IQUOTIENT (STRINGWIDTH COMP COMPFONT)
|
||||
2))
|
||||
STREAM)
|
||||
(PRIN1 COMP STREAM)
|
||||
(DSPFONT MAINFONT STREAM)
|
||||
(DSPXPOSITION (- LEFTSIDE (STRINGWIDTH FROM-STRING MAINFONT))
|
||||
STREAM)
|
||||
(PRIN1 FROM-STRING STREAM)
|
||||
(DSPXPOSITION RIGHTSIDE STREAM)
|
||||
(PRINTOUT STREAM TO-STRING T)))
|
||||
(T (* ;
|
||||
"the display, where TAB does work.")
|
||||
(PRINTOUT STREAM FROM (COND
|
||||
(FROMAUTHOR (CONCAT "(" FROMAUTHOR ")"))
|
||||
(T " "))
|
||||
45
|
||||
(IF FDATE
|
||||
THEN (CONCAT "[" FDATE "]")
|
||||
ELSEIF TDATE
|
||||
THEN (SPACES (IPLUS 2 (NCHARS TDATE)))
|
||||
ELSE "")
|
||||
-2 COMP -2 (IF TDATE
|
||||
THEN (CONCAT "[" TDATE "]")
|
||||
ELSE "")
|
||||
-1 TO (COND
|
||||
(TOAUTHOR (CONCAT "(" TOAUTHOR ")"))
|
||||
(T ""))
|
||||
T])
|
||||
|
||||
(COMPAREDIRECTORIES.NEWPAGEFN
|
||||
[LAMBDA (LISTINGSTREAM) (* ; "Edited 15-Nov-88 19:20 by jds")
|
||||
|
||||
(* ;; "Print the new-page headings on a COMPARE-DIRECTORIES page.")
|
||||
|
||||
(LET* ((LEFT (DSPLEFTMARGIN NIL LISTINGSTREAM))
|
||||
(RIGHT (DSPRIGHTMARGIN NIL LISTINGSTREAM))
|
||||
(TITLEFONT (FONTCREATE 'MODERN 10 'BOLD NIL LISTINGSTREAM))
|
||||
(TITLE (STREAMPROP LISTINGSTREAM 'TITLE))
|
||||
(HEAD-WIDTH (IQUOTIENT (STRINGWIDTH (CAR TITLE)
|
||||
TITLEFONT)
|
||||
2))
|
||||
(CENTER (IQUOTIENT (+ LEFT RIGHT)
|
||||
2)))
|
||||
(DSPFONT TITLEFONT LISTINGSTREAM)
|
||||
(MOVETO (- CENTER HEAD-WIDTH)
|
||||
(DSPTOPMARGIN NIL LISTINGSTREAM)
|
||||
LISTINGSTREAM)
|
||||
(PRIN1 (CAR TITLE)
|
||||
LISTINGSTREAM)
|
||||
(MOVETO (- RIGHT (STRINGWIDTH (CDR TITLE)
|
||||
TITLEFONT))
|
||||
1270 LISTINGSTREAM)
|
||||
(PRIN1 (CDR TITLE)
|
||||
LISTINGSTREAM)
|
||||
(MOVETO LEFT [IDIFFERENCE (DSPTOPMARGIN NIL LISTINGSTREAM)
|
||||
(FIXR (FTIMES 1.5 (FONTPROP TITLEFONT 'HEIGHT]
|
||||
LISTINGSTREAM])
|
||||
|
||||
(COMPARE-DIRECTORIES
|
||||
[LAMBDA (FROMDIR TODIR SHOW=FILESTOO FILEPATTERN LISTINGFILE EXTENSIONSTOAVOID)
|
||||
(* ; "Edited 3-Nov-94 15:06 by jds")
|
||||
|
||||
(* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW=FILESTOO, then files that are the same are also listed. LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.")
|
||||
|
||||
(LET ((LISTINGSTREAM (COND
|
||||
[LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'INTERPRESS '(LANDSCAPE T]
|
||||
(T NIL)))
|
||||
FROM-GENERATOR TO-GENERATOR)
|
||||
(COND
|
||||
(LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN)
|
||||
[STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT FROMDIR " vs " TODIR)
|
||||
(CONCAT "as of " (DATE]
|
||||
(COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM)))
|
||||
[SETQ FROM-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY FROMDIR 'BODY
|
||||
(OR FILEPATTERN '*.*;))
|
||||
NIL
|
||||
'(SORT]
|
||||
[SETQ TO-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY TODIR 'BODY
|
||||
(OR FILEPATTERN '*.*;))
|
||||
NIL
|
||||
'(SORT]
|
||||
[bind FROM-FILE TO-FILE first (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))
|
||||
(SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))
|
||||
repeatwhile (OR FROM-FILE TO-FILE) bind DT1 DT2 TON SHORT-FROM SHORT-TO
|
||||
do (COND
|
||||
((AND FROM-FILE (CL:MEMBER (UNPACKFILENAME.STRING FROM-FILE 'EXTENSION)
|
||||
EXTENSIONSTOAVOID :TEST #'STRING-EQUAL))
|
||||
|
||||
(* ;; "FROM file is on the prohibited-extension list. Skip it.")
|
||||
|
||||
(SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)))
|
||||
((AND TO-FILE (CL:MEMBER (UNPACKFILENAME.STRING TO-FILE 'EXTENSION)
|
||||
EXTENSIONSTOAVOID :TEST #'STRING-EQUAL))
|
||||
|
||||
(* ;; "TO file is on the prohibited-extension list. Skip it.")
|
||||
|
||||
(SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)))
|
||||
(T (SETQ SHORT-FROM (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL
|
||||
'BODY FROM-FILE))
|
||||
(SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL
|
||||
'BODY TO-FILE))
|
||||
(HELP)
|
||||
(COND
|
||||
((NOT FROM-FILE)
|
||||
|
||||
(* ;; " Ran out of FROM files first; print the missing-FROM marker")
|
||||
|
||||
(COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**"
|
||||
(GETFILEINFO TO-FILE 'CREATIONDATE)
|
||||
SHORT-TO
|
||||
(GETFILEINFO TO-FILE 'AUTHOR))
|
||||
(SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)))
|
||||
((NOT TO-FILE)
|
||||
|
||||
(* ;; " Ran out of TO files first; print the missing-TO marker")
|
||||
|
||||
(COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO
|
||||
FROM-FILE
|
||||
'AUTHOR)
|
||||
(GETFILEINFO FROM-FILE 'CREATIONDATE)
|
||||
"**" "" "" "")
|
||||
(SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)))
|
||||
((CL:STRING-LESSP SHORT-FROM SHORT-TO)
|
||||
|
||||
(* ;;
|
||||
"This FROM file has no TO equivalent. Print the missing-FROM marker")
|
||||
|
||||
(COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO
|
||||
FROM-FILE
|
||||
'AUTHOR)
|
||||
(GETFILEINFO FROM-FILE 'CREATIONDATE)
|
||||
"**" "" "" "")
|
||||
(SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)))
|
||||
((CL:STRING-LESSP SHORT-TO SHORT-FROM)
|
||||
|
||||
(* ;;
|
||||
"This TO file has no FROM equivalent. Print the missing-TO marker")
|
||||
|
||||
(COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**"
|
||||
(GETFILEINFO TO-FILE 'CREATIONDATE)
|
||||
SHORT-TO
|
||||
(GETFILEINFO TO-FILE 'AUTHOR))
|
||||
(SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)))
|
||||
([= (SETQ DT1 (GETFILEINFO FROM-FILE 'ICREATIONDATE))
|
||||
(SETQ DT2 (GETFILEINFO TO-FILE 'ICREATIONDATE]
|
||||
(AND SHOW=FILESTOO (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM
|
||||
"" (GDATE DT1)
|
||||
"=="
|
||||
(GDATE DT2)
|
||||
SHORT-TO ""))
|
||||
(SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))
|
||||
(SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)))
|
||||
(T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM
|
||||
(GETFILEINFO FROM-FILE 'AUTHOR)
|
||||
(GDATE DT1)
|
||||
(COND
|
||||
((LESSP DT1 DT2)
|
||||
"<<")
|
||||
(T ">>"))
|
||||
(GDATE DT2)
|
||||
SHORT-TO
|
||||
(GETFILEINFO TO-FILE 'AUTHOR))
|
||||
(SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))
|
||||
(SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR]
|
||||
(AND LISTINGSTREAM (CLOSEF LISTINGSTREAM])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "look for compiled files older than the sources")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(FIND-UNCOMPILED-FILES
|
||||
[LAMBDA (FROMDIR TODIR LISTINGFILE) (* ; "Edited 3-Nov-94 15:17 by jds")
|
||||
|
||||
(* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW=FILESTOO, then files that are the same are also listed. LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.")
|
||||
|
||||
(LET ((LISTINGSTREAM (COND
|
||||
[LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'POSTSCRIPT '(LANDSCAPE T]
|
||||
(T NIL)))
|
||||
FROM-GENERATOR TO-GENERATOR)
|
||||
(COND
|
||||
(LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN)
|
||||
[STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT "Compiled-file search of " FROMDIR
|
||||
" vs " TODIR)
|
||||
(CONCAT "as of " (DATE]
|
||||
(COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM)))
|
||||
[SETQ FROM-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY FROMDIR 'BODY "*.;")
|
||||
NIL
|
||||
'(SORT]
|
||||
(bind FROM-FILE first (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))
|
||||
repeatwhile FROM-FILE bind DT1 DT2 TON SHORT-FROM SHORT-TO
|
||||
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
Binary file not shown.
File diff suppressed because one or more lines are too long
@@ -1,228 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "28-Jun-89 08:53:23" {POOH/N}<POOH>MAXWELL>LISP>LAFITETIMEDDELETE;1 11153
|
||||
|
||||
changes to%: (FNS \LAFITE.DELETEEXPIRED MESSAGEAGE)
|
||||
|
||||
previous date%: "13-Oct-88 11:05:53" {PHYLUM}<LISPUSERS>MEDLEY>LAFITETIMEDDELETE.;1)
|
||||
|
||||
|
||||
(* "
|
||||
Copyright (c) 1987, 1988, 1989 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT LAFITETIMEDDELETECOMS)
|
||||
|
||||
(RPAQQ LAFITETIMEDDELETECOMS
|
||||
((DECLARE%: DONTCOPY EVAL@COMPILE (FILES LAFITEDECLS))
|
||||
(FILES LAFITEFIND)
|
||||
(FNS \LAFITE.TIMEDDELETE \LAFITE.SETEXPIRATIONS \LAFITE.DELETEEXPIRED)
|
||||
(FNS LTD.INIT MESSAGEAGE)
|
||||
(INITVARS EXPIRATIONMENU)
|
||||
(VARS EXPIRATIONMENUITEMS MARKDURATIONS)
|
||||
(GLOBALVARS EXPIRATIONMENU EXPIRATIONMENUITEMS MARKDURATIONS)
|
||||
(P (LTD.INIT))))
|
||||
(DECLARE%: DONTCOPY EVAL@COMPILE
|
||||
|
||||
(FILESLOAD LAFITEDECLS)
|
||||
)
|
||||
|
||||
(FILESLOAD LAFITEFIND)
|
||||
(DEFINEQ
|
||||
|
||||
(\LAFITE.TIMEDDELETE
|
||||
[LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* jtm%: "30-Sep-87 14:25")
|
||||
(COND
|
||||
((EQ KEY 'MIDDLE)
|
||||
(\LAFITE.SETEXPIRATIONS WINDOW MAILFOLDER ITEM MENU))
|
||||
(T (\LAFITE.DELETE WINDOW MAILFOLDER ITEM MENU])
|
||||
|
||||
(\LAFITE.SETEXPIRATIONS
|
||||
[LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 21-Sep-88 16:36 by jtm:")
|
||||
(WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER)
|
||||
[LET (EXPIRATION DURATION MSGDURATION MSGEXPIRATION TODAY YEAR ONEDAY MESSAGEAGE (N 0)
|
||||
(NODATE 0))
|
||||
(\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER)
|
||||
(COND
|
||||
[[SETQ EXPIRATION
|
||||
(MENU (OR EXPIRATIONMENU
|
||||
(SETQ EXPIRATIONMENU
|
||||
(create MENU
|
||||
MENUFONT _ LAFITEMENUFONT
|
||||
TITLE _ "Expiration date"
|
||||
CENTERFLG _ T
|
||||
ITEMS _ EXPIRATIONMENUITEMS]
|
||||
(SETQ DURATION (CADR (FASSOC EXPIRATION MARKDURATIONS)))
|
||||
[AND DURATION (add DURATION (IMINUS (IQUOTIENT DURATION 10]
|
||||
|
||||
(* this is so yesterday's messages won't be marked as 4 months when you ask for
|
||||
2.0)
|
||||
|
||||
[COND
|
||||
((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER))
|
||||
(SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00")
|
||||
(IDATE "1-Jan-80 12:00")))
|
||||
(SETQ TODAY (IPLUS (IDATE (DATE))
|
||||
(IQUOTIENT ONEDAY 2)))
|
||||
(* treat "now" as being after noon
|
||||
for the purposes of counting days.)
|
||||
(SETQ YEAR (SUBSTRING (DATE)
|
||||
8 9))
|
||||
(for MSG selectedin MAILFOLDER
|
||||
when (OR (EQ EXPIRATION 0)
|
||||
(NOT (fetch (LAFITEMSG DELETED?) of MSG)))
|
||||
do (COND
|
||||
((EQ EXPIRATION T)
|
||||
(DELETEMESSAGE MSG MAILFOLDER))
|
||||
((EQ EXPIRATION 0) (* equivalent to undelete.)
|
||||
(UNDELETEMESSAGE MSG MAILFOLDER)
|
||||
(MARKMESSAGE MSG MAILFOLDER 32))
|
||||
((SETQ MESSAGEAGE (MESSAGEAGE MSG TODAY YEAR ONEDAY))
|
||||
(SETQ MSGDURATION (IPLUS DURATION MESSAGEAGE))
|
||||
(SETQ MSGEXPIRATION (OR [CAR (for ITEM in MARKDURATIONS
|
||||
thereis (ILEQ MSGDURATION
|
||||
(CADR ITEM]
|
||||
9))
|
||||
(MARKMESSAGE MSG MAILFOLDER (IPLUS 48 MSGEXPIRATION)))
|
||||
(T (* the message didn't have a date.
|
||||
Flag the message with a ?)
|
||||
(add NODATE 1)
|
||||
(MARKMESSAGE MSG MAILFOLDER 63)))
|
||||
(add N 1]
|
||||
(COND
|
||||
((EQ NODATE 0)
|
||||
(LAB.PROMPTPRINT MAILFOLDER T "Marked " N " " (COND
|
||||
((EQ N 1)
|
||||
"message")
|
||||
(T "messages"))
|
||||
" to expire after "
|
||||
[CAR (for I in EXPIRATIONMENUITEMS
|
||||
thereis (EQ EXPIRATION (CADR I]
|
||||
"."))
|
||||
(T (LAB.PROMPTPRINT MAILFOLDER T "Error: " NODATE " " (COND
|
||||
((EQ NODATE 1)
|
||||
"message")
|
||||
(T "messages"))
|
||||
" had a bad date."]
|
||||
(T (LAB.PROMPTPRINT MAILFOLDER T "No expiration date selected."])])
|
||||
|
||||
(\LAFITE.DELETEEXPIRED
|
||||
[LAMBDA (MAILFOLDER) (* ; "Edited 22-Jun-89 09:39 by jtm:")
|
||||
(* ; "Edited 22-Jun-89 09:39 by jtm:")
|
||||
(* ; "Edited 22-Jun-89 09:37 by jtm:")
|
||||
(* ; "Edited 22-Jun-89 09:36 by jtm:")
|
||||
(* ; "Edited 22-Jun-89 09:22 by jtm:")
|
||||
(* ; "Edited 21-Sep-88 16:39 by jtm:")
|
||||
(LET (MESSAGES LASTMSG# YEAR TODAY ONEDAY MISSING (N 0))
|
||||
(SETQ MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER))
|
||||
(SETQ LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER))
|
||||
(SETQ TODAY (IDATE (DATE)))
|
||||
(SETQ YEAR (SUBSTRING (DATE)
|
||||
8 9))
|
||||
(SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00")
|
||||
(IDATE "1-Jan-80 12:00")))
|
||||
[for I MSG MARK MSGAGE DURATION from 1 to LASTMSG#
|
||||
do (SETQ MSG (NTHMESSAGE MESSAGES I))
|
||||
(SETQ MARK (fetch (LAFITEMSG MARKCHAR) of MSG))
|
||||
(COND
|
||||
((AND (IGREATERP MARK 48)
|
||||
(ILESSP MARK 58)
|
||||
(NOT (fetch (LAFITEMSG DELETED?) of MSG)))
|
||||
(SETQ MSGAGE (MESSAGEAGE MSG TODAY YEAR ONEDAY))
|
||||
(SETQ DURATION (CADR (FASSOC (IDIFFERENCE MARK 48)
|
||||
MARKDURATIONS)))
|
||||
(COND
|
||||
((NULL MSGAGE)
|
||||
(push MISSING I))
|
||||
((AND DURATION (IGEQ MSGAGE DURATION))
|
||||
(DELETEMESSAGE MSG MAILFOLDER)
|
||||
(add N 1]
|
||||
(COND
|
||||
(MISSING (SETQ MISSING (DREVERSE MISSING))
|
||||
(LAB.PROMPTPRINT MAILFOLDER T "The dates for " MISSING " cannot be parsed."))
|
||||
(T (LAB.PROMPTPRINT MAILFOLDER T N " expired " (COND
|
||||
((EQ N 1)
|
||||
"message")
|
||||
(T "messages"))
|
||||
" deleted."])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(LTD.INIT
|
||||
[LAMBDA NIL (* jtm%: "30-Sep-87 16:44")
|
||||
(LET (DELETEMENUITEM)
|
||||
(COND
|
||||
((SETQ DELETEMENUITEM (SASSOC "Delete" LAFITEBROWSERMENUITEMS))
|
||||
(RPLACA (CDR DELETEMENUITEM)
|
||||
''\LAFITE.TIMEDDELETE)
|
||||
(COND
|
||||
((NOT (SASSOC "Delete Expired Msgs" LAFITEEXTRAMENUITEMS))
|
||||
(push LAFITEEXTRAMENUITEMS '("Delete Expired Msgs" (FUNCTION
|
||||
\LAFITE.DELETEEXPIRED)
|
||||
|
||||
"Mark as deleted all of the messages that have passed their expiration dates."
|
||||
))
|
||||
(SETQ LAFITEEXTRAMENU NIL)
|
||||
(SETQ LAFITEEXTRAMENUFLG T])
|
||||
|
||||
(MESSAGEAGE
|
||||
[LAMBDA (MSG TODAY YEAR ONEDAY) (* ; "Edited 22-Jun-89 11:46 by jtm:")
|
||||
(* ; "Edited 21-Sep-88 16:25 by jtm:")
|
||||
(LET (MSGDATE MSGTIME)
|
||||
[COND
|
||||
((AND (fetch (LAFITEMSG DATEKNOWN?) of MSG)
|
||||
(SETQ MSGTIME (fetch (LAFITEMSG IDATE) of MSG)))
|
||||
|
||||
(* ;; "new format: date already parsed.")
|
||||
|
||||
NIL)
|
||||
((SETQ MSGDATE (fetch (LAFITEMSG DATE) of MSG))
|
||||
[OR TODAY (SETQ TODAY (IDATE (DATE]
|
||||
(OR YEAR (SETQ YEAR (SUBSTRING (DATE)
|
||||
8 9)))
|
||||
[OR ONEDAY (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00")
|
||||
(IDATE "1-Jan-80 12:00"]
|
||||
(SETQ MSGTIME (IDATE (CONCAT MSGDATE " " YEAR " 12:00")))
|
||||
(COND
|
||||
((AND MSGTIME (IGREATERP (IDIFFERENCE MSGTIME TODAY)
|
||||
ONEDAY)) (* a message from last year.)
|
||||
(SETQ MSGTIME (IDATE (CONCAT MSGDATE " " (SUB1 (MKATOM YEAR))
|
||||
" 12:00"]
|
||||
(AND MSGTIME (QUOTIENT (IDIFFERENCE TODAY MSGTIME)
|
||||
ONEDAY])
|
||||
)
|
||||
|
||||
(RPAQ? EXPIRATIONMENU NIL)
|
||||
|
||||
(RPAQQ EXPIRATIONMENUITEMS
|
||||
(("now" T)
|
||||
("one day" 1)
|
||||
("two days" 2)
|
||||
("four days" 3)
|
||||
("one week" 4)
|
||||
("two weeks" 5)
|
||||
("one month" 6)
|
||||
("two months" 7)
|
||||
("four months" 8)
|
||||
("eight months" 9)
|
||||
("forever" 0)))
|
||||
|
||||
(RPAQQ MARKDURATIONS ((1 1)
|
||||
(2 2)
|
||||
(3 4)
|
||||
(4 7)
|
||||
(5 14)
|
||||
(6 30)
|
||||
(7 61)
|
||||
(8 122)
|
||||
(9 244)))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS EXPIRATIONMENU EXPIRATIONMENUITEMS MARKDURATIONS)
|
||||
)
|
||||
|
||||
(LTD.INIT)
|
||||
(PUTPROPS LAFITETIMEDDELETE COPYRIGHT ("Xerox Corporation" 1987 1988 1989))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (934 8084 (\LAFITE.TIMEDDELETE 944 . 1218) (\LAFITE.SETEXPIRATIONS 1220 . 5600) (
|
||||
\LAFITE.DELETEEXPIRED 5602 . 8082)) (8085 10316 (LTD.INIT 8095 . 8984) (MESSAGEAGE 8986 . 10314)))))
|
||||
STOP
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
@@ -1,225 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 7-Sep-89 12:31:44" "{piglet/n}<piglet>vanmelle>lispusers>nsprotection;4" 31274
|
||||
|
||||
changes to%: (FNS NSPROT.SET.MULTIPLE))
|
||||
|
||||
|
||||
(* "
|
||||
Copyright (c) 1987, 1989 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT NSPROTECTIONCOMS)
|
||||
|
||||
(RPAQQ NSPROTECTIONCOMS ((COMS (* ; "Main window selection handlers") (FNS NSPROTECTION NSPROT.SHOW NSPROT.FETCH.PROTECTION NSPROT.NEW.ENTRY NSPROT.APPLY NSPROT.SET.PROTECTION NSPROT.SET.PROTECTION.ONE NSPROT.SET.MULTIPLE NSPROT.SET.TO.DEFAULT NSPROT.BEGIN.COMMAND) (FNS NSPROT.HANDLE.TYPE NSPROT.RESTORE.TYPE NSPROT.HANDLE.VERIFY NSPROT.RESTORE.VERIFY NSPROT.PARSE.FILENAME NSPROT.PARSE.PROTECTIONS NSPROT.STRIP.HOST NSPROT.EXPAND.FULLNAME)) (COMS (* ; "Handle protection submenus") (FNS NSPROT.GET.SUBMENU NSPROT.ADD.SUBMENU NSPROT.REMOVE.SUBMENUS NSPROT.CHANGE.STATE NSPROT.HANDLE.ALL NSPROT.MESSAGE.ALL NSPROT.HANDLE.SUBTYPE NSPROT.SHOW.PROT.VALUE)) (COMS (* ; "utilities") (FNS NSPROT.DIRECTORY.SYNTAXP NSPROT.TOP.LEVELP NSPROT.GET.FONT NSPROT.PROMPT NSPROT.CLEAR.PROMPT NSPROT.LIMITCHARS NSPROT.PAGEFULLFN NSPROT.ICONFN)) (INITVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT) (VARS NSPROT.ICON) (GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON \DEFAULTTTYDISPLAYSTREAM) (LOCALVARS . T) (COMS (DECLARE%: DONTEVAL@LOAD DOCOPY (P (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)))) (FNS ADD.NSPROTECTION) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (ADD.NSPROTECTION)))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA NSPROT.PROMPT)))))
|
||||
|
||||
|
||||
|
||||
(* ; "Main window selection handlers")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(NSPROTECTION
|
||||
(LAMBDA NIL (* ; "Edited 1-Sep-87 10:31 by bvm:") (* ;; "Main entry--create the NS protection tool main window and prompt window.") (LET* ((PLAINFONT (NSPROT.GET.FONT)) (BOLDFONT (NSPROT.GET.FONT T)) (HEIGHTDIFFERENCE (- (FONTPROP BOLDFONT (QUOTE HEIGHT)) (FONTPROP PLAINFONT (QUOTE HEIGHT)))) (W (FREEMENU (BQUOTE ((PROPS COLUMNSPACE 14 FONT (\, BOLDFONT)) ((LABEL "Show" SELECTEDFN NSPROT.SHOW MESSAGE "Show the current protection of the specified directory/file.") (LABEL "New Entry" SELECTEDFN NSPROT.NEW.ENTRY MESSAGE "Add a new protection entry (you fill it in).") (LABEL "Apply" SELECTEDFN NSPROT.APPLY MESSAGE "Apply the indicated protections to the file.") (LABEL "Set to Default" SELECTEDFN NSPROT.SET.TO.DEFAULT MESSAGE "Make the file inherit protection from its parent (sub)directory." MAXWIDTH 275)) ((PROPS COLUMNSPACE 4) (LABEL "Type:" TYPE STATE CHANGESTATE NSPROT.HANDLE.TYPE INITSTATE "Principal" MESSAGE "Show directory's own protection, or default for its children? (can be different)" ID TYPE LINKS (DISPLAY PROTECTION-TYPE)) (LABEL "" TYPE DISPLAY ID PROTECTION-TYPE FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE) MAXWIDTH (\, (STRINGWIDTH "Children Only " PLAINFONT))) (LABEL "Check:" TYPE STATE CHANGESTATE NSPROT.HANDLE.VERIFY INITSTATE "New Names Only" MESSAGE "Check names in protection entries against Clearinghouse?" ID CHECK LINKS (DISPLAY VERIFYFLG)) (LABEL "" TYPE DISPLAY ID VERIFYFLG FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE) MAXWIDTH (\, (STRINGWIDTH "New Names Only" PLAINFONT)))) ((PROPS COLUMNSPACE (\, (+ 6 (- (STRINGWIDTH "Dir/File:" BOLDFONT) (STRINGWIDTH "Host:" BOLDFONT))))) (LABEL "Host:" TYPE EDITSTART MESSAGE "Fill in the name of the NS file server" LINKS (EDIT HOST)) (LABEL (\, (CONCAT)) TYPE EDIT ID HOST LIMITCHARS NSPROT.LIMITCHARS FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE))) ((PROPS COLUMNSPACE 6) (LABEL "Dir/File:" TYPE EDITSTART MESSAGE "Fill in the name of the desired directory or file." LINKS (EDIT DIR)) (LABEL (\, (CONCAT)) TYPE EDIT ID DIR LIMITCHARS NSPROT.LIMITCHARS FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE))))) "NS File Protection Tool")) (REG (WINDOWREGION W)) PW) (* ;; "The HEIGHTDIFFERENCE hacking is to get the baselines of the bold and plain fonts to line up (odd that they don't already). (CONCAT) instead of %"%" to ease my pain of debugging--otherwise, the edit items would all be fat, and Lyric's Courier doesn't handle that gracefully.") (WINDOWPROP W (QUOTE FM.DONTRESHAPE) T) (WINDOWPROP W (QUOTE MINSIZE) (CONS (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG))) (* ; "Don't let window shape any smaller than it is.") (WINDOWPROP W (QUOTE VERIFYFLG) :NEW) (WINDOWPROP W (QUOTE PROTECTION-TYPE) T) (WINDOWPROP W (QUOTE ICONFN) (FUNCTION NSPROT.ICONFN)) (MOVEW W (GETBOXPOSITION (fetch (REGION WIDTH) of REG) (+ (fetch (REGION HEIGHT) of REG) (HEIGHTIFWINDOW (FONTPROP PLAINFONT (QUOTE HEIGHT)))))) (OPENW W) (SETQ PW (GETPROMPTWINDOW W NIL PLAINFONT)) (* ; "Arrange for prompt window to expand itself by one line at a time if it overflows") (WINDOWPROP PW (QUOTE PAGEFULLFN) (QUOTE NSPROT.PAGEFULLFN)) (WINDOWPROP W (QUOTE FM.PROMPTWINDOW) PW) NIL))
|
||||
)
|
||||
|
||||
(NSPROT.SHOW
|
||||
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 1-Sep-87 10:50 by bvm:") (LET ((DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW)) OLDWINDOWS) (if DEV&FILESPEC then (NSPROT.REMOVE.SUBMENUS WINDOW) (CL:MULTIPLE-VALUE-BIND (PROT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (NSPROT.FETCH.PROTECTION WINDOW DEV FILESPEC))) (if CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION) ELSE (for P in PROT do (NSPROT.SHOW.PROT.VALUE P WINDOW))) (NSPROT.RESTORE.VERIFY WINDOW)))))
|
||||
)
|
||||
|
||||
(NSPROT.FETCH.PROTECTION
|
||||
(LAMBDA (WINDOW DEV FILESPEC) (* ; "Edited 3-Dec-87 17:09 by bvm:") (* ;; "Return the access list of FILESPEC on DEV of the flavor requested by window (or implicitly by the filespec being a non-directory). This fn prints its own messages when the defaulting is interesting.") (if (SETQ FILESPEC (NSPROT.EXPAND.FULLNAME WINDOW DEV FILESPEC)) then (LET* ((TYPE (if (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) then (QUOTE DEFAULT.ACCESS.LIST) else (QUOTE ACCESS.LIST))) TOPLEVELP (DIRP (NSPROT.DIRECTORY.SYNTAXP FILESPEC)) (DESIREDPROPS (if DIRP then (* ; "Check both kinds of access list, and if top-level also get usage stats") (BQUOTE ((\,@ (CONSTANT (LIST (\FILING.ATTRIBUTE.TYPE (QUOTE ACCESS.LIST)) (\FILING.ATTRIBUTE.TYPE (QUOTE DEFAULT.ACCESS.LIST))))) (\,@ (AND (EQ TYPE (QUOTE ACCESS.LIST)) (SETQ TOPLEVELP (NSPROT.TOP.LEVELP FILESPEC)) (CONSTANT (LIST (\FILING.ATTRIBUTE.TYPE (QUOTE SUBTREE.SIZE)) (\FILING.ATTRIBUTE.TYPE (QUOTE SUBTREE.SIZE.LIMIT)))))))) else (LIST (\FILING.ATTRIBUTE.TYPE TYPE)))) (PROPS (\NSFILING.GET/SETINFO DEV FILESPEC (FUNCTION \NSFILING.GET.ATTRIBUTES))) PROT OTHER) (DECLARE (CL:SPECIAL DESIREDPROPS)) (* ; "Go thru internal filing interface in order to intercept errors and get more than one attribute at once. DESIREDPROPS is used free under \nsfiling.get/setinfo.") (if (OR (NULL PROPS) (EQ (CAR PROPS) (QUOTE ERROR))) then (NSPROT.PROMPT WINDOW "Failed: ~A" (CADDR PROPS)) elseif (NULL (SETQ PROT (CADR (ASSOC TYPE PROPS)))) then (NSPROT.PROMPT WINDOW "Failed to fetch protection.") else (if (AND DIRP (EQ TYPE (QUOTE ACCESS.LIST)) (SETQ OTHER (CADR (ASSOC (QUOTE DEFAULT.ACCESS.LIST) PROPS))) (NOT (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of OTHER))) then (* ; "We're fetching the principal access list for a directory, but it has a non-defaulted DEFAULT.ACCESS.LIST, so warn user") (NSPROT.PROMPT WINDOW "Note: this ~:[~;protection is inherited, but the ~]directory has a separate default protection for its children." (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of PROT)) elseif (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of PROT) then (* ; "defaulted value, explain.") (if (EQ TYPE (QUOTE ACCESS.LIST)) then (NSPROT.PROMPT WINDOW "The protection shown is inherited from the parent.") else (NSPROT.PROMPT WINDOW "This is the directory's principal protection~:[~;, which is itself inherited~]." (AND (SETQ OTHER (CADR (ASSOC (QUOTE ACCESS.LIST) PROPS))) (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of OTHER))))) (if TOPLEVELP then (* ; "Top-level directory, also give usage stats.") (LET ((USED (CADR (ASSOC (QUOTE SUBTREE.SIZE) PROPS))) (LIMIT (CADR (ASSOC (QUOTE SUBTREE.SIZE.LIMIT) PROPS)))) (NSPROT.PROMPT WINDOW "~&Directory contains ~D pages ~:[(unlimited allocation)~;out of ~:*~D allocated~]" (FOLDHI USED BYTESPERPAGE) (AND (>= LIMIT 0) (FOLDHI LIMIT BYTESPERPAGE))))) (COURIER.FETCH (FILING . ACCESS.LIST) ENTRIES of PROT)))))
|
||||
)
|
||||
|
||||
(NSPROT.NEW.ENTRY
|
||||
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 24-Aug-87 16:14 by bvm:") (* ;; "Handles the NEW ENTRY button -- adds another protection entry and starts editing the name field of it") (NSPROT.BEGIN.COMMAND WINDOW) (LET* ((SUBW (NSPROT.GET.SUBMENU WINDOW)) (NAMEITEM (FM.GETITEM (QUOTE NAME) NIL SUBW))) (FM.CHANGESTATE (FM.GETITEM (QUOTE READ) NIL SUBW) T SUBW) (* ; "Initial protection = READ") (FM.CHANGELABEL NAMEITEM (CONCAT) SUBW) (* ; "Initial name is empty") (WINDOWPROP SUBW (QUOTE KNOWN-VALUE) NIL) (* ; "erase any previous cache") (NSPROT.ADD.SUBMENU SUBW WINDOW) (FM.EDITITEM NAMEITEM SUBW)))
|
||||
)
|
||||
|
||||
(NSPROT.APPLY
|
||||
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Aug-87 14:38 by bvm:") (LET (DEV&FILESPEC PROT) (if (AND (MOUSECONFIRM "Click LEFT to confirm setting the displayed protection" T (GETPROMPTWINDOW WINDOW)) (SETQ DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW)) (SETQ PROT (NSPROT.PARSE.PROTECTIONS WINDOW))) then (if (AND (NULL (SETQ PROT (CAR PROT))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) then (NSPROT.PROMPT WINDOW "Can't set empty protection.") elseif (AND (for PAIR in PROT never (MEMB (QUOTE OWNER) (CADR PAIR))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) then (NSPROT.PROMPT WINDOW T "Can't: Somebody must retain owner access.") else (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (NSPROT.SET.PROTECTION WINDOW DEV FILESPEC PROT))) (IF CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION)))) (NSPROT.RESTORE.VERIFY WINDOW))))
|
||||
)
|
||||
|
||||
(NSPROT.SET.PROTECTION
|
||||
(LAMBDA (WINDOW DEV FILESPEC PROT) (* ; "Edited 31-Aug-87 18:22 by bvm:") (if (STRPOS "*" FILESPEC) then (NSPROT.SET.MULTIPLE WINDOW DEV FILESPEC PROT) elseif (NULL (NSPROT.EXPAND.FULLNAME WINDOW DEV FILESPEC)) elseif (NSPROT.SET.PROTECTION.ONE DEV FILESPEC PROT (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS))) then (NSPROT.PROMPT WINDOW "Done, ~:[~;children's default ~]protection set ~A." (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) (if (EQ PROT T) then "to default" else "as shown")) else (NSPROT.PROMPT WINDOW "Failed to set protection.")))
|
||||
)
|
||||
|
||||
(NSPROT.SET.PROTECTION.ONE
|
||||
(LAMBDA (DEV FILESPEC PROT DEFAULTP) (* ; "Edited 27-Aug-87 13:51 by bvm:") (* ;; "Performs the filing call that sets the protection of FILESPEC on DEV to be PROT. PROT=T means default protection. DEFAULTP = NIL means access, T means default access.") (if (EQ PROT T) then (* ; "Set to default protection. Can't do this in the obvious way, because the PROTECTION attribute hides the hair about defaulted") (\NSFILING.SETFILEINFO FILESPEC (if DEFAULTP then (CONSTANT (\FILING.ATTRIBUTE.TYPE (QUOTE DEFAULT.ACCESS.LIST))) else (CONSTANT (\FILING.ATTRIBUTE.TYPE (QUOTE ACCESS.LIST)))) (CONSTANT (COURIER.WRITE.REP (COURIER.CREATE (FILING . ACCESS.LIST) ENTRIES _ NIL DEFAULTED _ T) (QUOTE FILING) (QUOTE ACCESS.LIST))) DEV) else (\NSFILING.SETFILEINFO FILESPEC (if DEFAULTP then (QUOTE DEFAULT.ACCESS.LIST) else (QUOTE PROTECTION)) PROT DEV)))
|
||||
)
|
||||
|
||||
(NSPROT.SET.MULTIPLE
|
||||
(LAMBDA (WINDOW DEV FILESPEC PROT) (* ; "Edited 7-Sep-89 12:31 by bvm") (if (NSPROT.RESTORE.TYPE WINDOW) then (NSPROT.PROMPT WINDOW "(Will set Principal protection) ")) (NSPROT.PROMPT WINDOW "Enumerating...") (LET ((FILES (RESETLST (LET* ((FILING.ENUMERATION.DEPTH MAX.SMALLP) (GEN (\GENERATEFILES (DIRECTORY.FILL.PATTERN FILESPEC) (QUOTE (FILE.ID)) (QUOTE (RESETLST)))) FILE) (DECLARE (CL:SPECIAL FILING.ENUMERATION.DEPTH)) (* ; "sets depth to infinity without telling the generator to filter out directories.") (while (SETQ FILE (\GENERATENEXTFILE GEN)) collect (NSPROT.PROMPT WINDOW T "~A" (SETQ FILE (CDR (NSPROT.STRIP.HOST FILE)))) (LIST (\GENERATEFILEINFO GEN (QUOTE FILE.ID)) (\GENERATEFILEINFO GEN (QUOTE IS.DIRECTORY)) FILE)))))) (if (NULL FILES) then (NSPROT.PROMPT WINDOW "no files match the pattern.") else (NSPROT.PROMPT WINDOW T "Setting...") (for F in FILES bind (OK _ 0) (FAILED _ 0) do (* ;; "Set explicit protection for file with this id. If it's a directory, also set its default access list to defaulted.") (if (AND (NSPROT.SET.PROTECTION.ONE DEV (BQUOTE (FILE.ID (\, (CAR F)))) PROT) (OR (NULL (CADR F)) (NSPROT.SET.PROTECTION.ONE DEV (BQUOTE (FILE.ID (\, (CAR F)))) T T))) then (add OK 1) else (add FAILED 1) (NSPROT.PROMPT WINDOW T "Failed on ~A" (CADDR F))) finally (NSPROT.PROMPT WINDOW T "Done, set ~A on ~D files~:[~; out of ~D~]." (if (EQ PROT T) then "default protection" else "the displayed protection") OK (NEQ FAILED 0) (+ OK FAILED))))))
|
||||
)
|
||||
|
||||
(NSPROT.SET.TO.DEFAULT
|
||||
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 20-Nov-87 12:26 by bvm:") (LET (DEV&FILESPEC PROT) (if (AND (MOUSECONFIRM "Click LEFT to confirm restoring the file to inherited protection" T (GETPROMPTWINDOW WINDOW)) (SETQ DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW))) then (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (if (AND (NSPROT.TOP.LEVELP FILESPEC) (NOT (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) THEN (* ; "Dangerous operation!") (NSPROT.PROMPT WINDOW "Can't set top-level directory to default protection.") ELSE (NSPROT.SET.PROTECTION WINDOW DEV FILESPEC T)))) (IF CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION))) (NSPROT.RESTORE.VERIFY WINDOW))))
|
||||
)
|
||||
|
||||
(NSPROT.BEGIN.COMMAND
|
||||
(LAMBDA (WINDOW) (* ; "Edited 20-Aug-87 17:35 by bvm:") (* ;; "Begin a new command. Clear old prompt window, if any, and stop any editing.") (LET ((PW (GETPROMPTWINDOW WINDOW NIL NIL T))) (AND PW (CLEARW PW))) (FM.ENDEDIT WINDOW) (for W in (WINDOWPROP WINDOW (QUOTE PROTMENUS)) do (FM.ENDEDIT W)) (if (EQ (GETSTREAM WINDOW) (TTYDISPLAYSTREAM)) then (* ; "Bug--freemenu leaves this guy being the ttydisplaystream") (TTYDISPLAYSTREAM \DEFAULTTTYDISPLAYSTREAM)))
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(NSPROT.HANDLE.TYPE
|
||||
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Aug-87 13:53 by bvm:") (LET (LABEL) (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS) (SELECTQ (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) (T (SETQ LABEL "Principal") NIL) (NIL (SETQ LABEL "Children Only") T) (SHOULDNT))) LABEL))
|
||||
)
|
||||
|
||||
(NSPROT.RESTORE.TYPE
|
||||
(LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 13:56 by bvm:") (* ;; "Replace the %"children only%" state with %"Principal%"--do this when working on a non-directory. Returns T if it changed.") (if (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS) NIL) then (FM.CHANGESTATE (FM.GETITEM (QUOTE TYPE) NIL WINDOW) "Principal" WINDOW) T))
|
||||
)
|
||||
|
||||
(NSPROT.HANDLE.VERIFY
|
||||
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 24-Aug-87 14:53 by bvm:") (LET (LABEL) (WINDOWPROP WINDOW (QUOTE VERIFYFLG) (SELECTQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) (:NEW (SETQ LABEL "All Names") T) (T (SETQ LABEL "Don't") NIL) (NIL (SETQ LABEL "I really mean it") :NO) (:NO (SETQ LABEL "New Names Only") :NEW) (SHOULDNT))) LABEL))
|
||||
)
|
||||
|
||||
(NSPROT.RESTORE.VERIFY
|
||||
(LAMBDA (WINDOW) (* ; "Edited 24-Aug-87 15:11 by bvm:") (* ;; "Replace the %"I really mean it%" state with a better one.") (if (EQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO) then (FM.CHANGESTATE (FM.GETITEM (QUOTE CHECK) NIL WINDOW) "New Names Only" WINDOW) (WINDOWPROP WINDOW (QUOTE VERIFYFLG) :NEW)))
|
||||
)
|
||||
|
||||
(NSPROT.PARSE.FILENAME
|
||||
(LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 14:45 by bvm:") (NSPROT.BEGIN.COMMAND WINDOW) (PROG ((STATE (FM.GETSTATE WINDOW)) HOST FILENAME FULLNAME HOST&FILE FULLHOST DEV) (for TL on STATE by (CDDR TL) do (SELECTQ (CAR TL) (HOST (SETQ HOST (CADR TL))) (DIR (SETQ FILENAME (CADR TL))) NIL)) (if (OR (NULL FILENAME) (EQ (NCHARS FILENAME) 0)) then (NSPROT.PROMPT WINDOW "No directory or file name was specified.") (RETURN NIL)) (if (SETQ HOST&FILE (NSPROT.STRIP.HOST FILENAME)) then (* ;; "User gave a full file name including host in the %"Dir/File%" field. Separate them out now.") (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) (SETQ FILENAME (CDR HOST&FILE)) WINDOW) (FM.CHANGELABEL (FM.GETITEM (QUOTE HOST) NIL WINDOW) (SETQ HOST (CAR HOST&FILE)) WINDOW)) (if (OR (NULL HOST) (EQ (NCHARS HOST) 0)) then (NSPROT.PROMPT WINDOW "No host was specified.") (RETURN NIL)) (SETQ FULLHOST (CAR (LOOKUP.NS.SERVER HOST NIL T))) (if (NOT (STRING-EQUAL HOST (SETQ HOST (NSNAME.TO.STRING (OR FULLHOST (PARSE.NSNAME HOST)) T)))) then (* ;; "Show fully-qualified name, either from lookup or from parse. In latter case, we may be reminding user of default domain.") (FM.CHANGELABEL (FM.GETITEM (QUOTE HOST) NIL WINDOW) HOST WINDOW)) (if (NEQ (CHCON1 FILENAME) (CHARCODE "<")) then (SETQ FILENAME (CONCAT "<" FILENAME)) (if (NOT (STRPOS ">" FILENAME 2)) then (SETQ FILENAME (CONCAT FILENAME ">"))) (* ; "Show modified file name") (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) FILENAME WINDOW)) (if (OR (NOT FULLHOST) (NULL (SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (CONCAT "{" HOST "}" FILENAME)) T)))) then (NSPROT.PROMPT WINDOW "Server ~A not found." HOST) (RETURN NIL)) (RETURN (CONS DEV FULLNAME))))
|
||||
)
|
||||
|
||||
(NSPROT.PARSE.PROTECTIONS
|
||||
(LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 14:45 by bvm:") (* ;; "Parse and as necessary validate the protection entries attached to WINDOW, returning a valid PROTECTION value, or NIL if something is wrong.") (LET ((PROTWINDOWS (WINDOWPROP WINDOW (QUOTE PROTMENUS))) (VERIFYFLG (WINDOWPROP WINDOW (QUOTE VERIFYFLG))) WHO HOW NSWHO OLDWHO FULLNAME DEADWINDOWS PROT VERIFIEDNAME) (for W in PROTWINDOWS do (SETQ WHO NIL) (SETQ HOW (for TAIL on (FM.GETSTATE W) by (CDDR TAIL) when (SELECTQ (CAR TAIL) ((READ WRITE ADD REMOVE OWNER) (CADR TAIL)) (NAME (SETQ WHO (CADR TAIL)) NIL) NIL) collect (CAR TAIL))) (if (NOT (AND HOW WHO (> (NCHARS WHO) 0))) then (* ; "No protection, remove this guy") (push DEADWINDOWS W) elseif (AND (NEQ VERIFYFLG T) (STREQUAL WHO (CAR (SETQ OLDWHO (WINDOWPROP W (QUOTE KNOWN-VALUE)))))) then (* ;; "This name hasn't been changed since we put it up, so use the parse that's there. We're assuming that not having to validate old protection names makes up for occasionally reinstalling a bogus name that just happened to be there.") (push PROT (LIST (CADR OLDWHO) HOW)) else (SETQ NSWHO (PARSE.NSNAME WHO)) (if (NOT (STREQUAL WHO (SETQ WHO (NSNAME.TO.STRING (OR (SETQ FULLNAME (if (SELECTQ VERIFYFLG ((NIL :NO) T) (STRPOS "*" WHO)) then (* ; "for now, accept any pattern") NSWHO else (* ; "get canonical name") (SETQ VERIFIEDNAME (CH.LOOKUP.OBJECT NSWHO)))) NSWHO) T)))) then (* ; "Show our parse or canonical name") (FM.CHANGELABEL (FM.GETITEM (QUOTE NAME) NIL W) WHO W)) (if FULLNAME then (* ; "good name") (SETQ NSWHO FULLNAME) (if VERIFIEDNAME then (* ; "Remember this parse") (WINDOWPROP W (QUOTE KNOWN-VALUE) (LIST WHO VERIFIEDNAME HOW))) else (NSPROT.PROMPT WINDOW "~A not a registered name." WHO) (RETURN NIL)) (push PROT (LIST NSWHO HOW))) finally (if DEADWINDOWS then (* ; "Remove the windows showing no entry") (LET ((LASTDEAD (CAR DEADWINDOWS)) LOWERWINDOWS) (* ; "First detach everything up to the last dead one.") (for OLDW in PROTWINDOWS do (DETACHWINDOW OLDW) (if (MEMB OLDW DEADWINDOWS) then (CLOSEW OLDW) else (push LOWERWINDOWS OLDW)) repeatuntil (EQ OLDW LASTDEAD)) (* ; "Now reattach the good ones") (for OLDW in LOWERWINDOWS do (ATTACHWINDOW OLDW WINDOW (QUOTE BOTTOM))) (* ; "Add the dead ones to scratch heap") (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS) (APPEND DEADWINDOWS (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS)))) (WINDOWPROP WINDOW (QUOTE PROTMENUS) (CL:SET-DIFFERENCE PROTWINDOWS DEADWINDOWS)))) (RETURN (LIST PROT)))))
|
||||
)
|
||||
|
||||
(NSPROT.STRIP.HOST
|
||||
(LAMBDA (FILENAME) (* ; "Edited 20-Aug-87 14:17 by bvm:") (* ;; "Strips the host field off the front of FILENAME and returns a dotted pair (host . restOfName).") (PROG (I) (RETURN (AND (SETQ I (STRPOS (SELCHARQ (CHCON1 FILENAME) ({ "}") ("[" "]") ("(" ")") (RETURN NIL)) FILENAME 2)) (CONS (SUBSTRING FILENAME 2 (SUB1 I)) (SUBSTRING FILENAME (ADD1 I)))))))
|
||||
)
|
||||
|
||||
(NSPROT.EXPAND.FULLNAME
|
||||
(LAMBDA (WINDOW DEV FILENAME) (* ; "Edited 27-Aug-87 15:19 by bvm:") (* ;; "Looks up FILENAME on DEV, returning the full name (sans host). WINDOW is the window in which FILENAME is the DIR item--we will change it if appropriate. Returns NIL on file not found.") (LET ((FULLNAME (\NSFILING.GETFILE DEV FILENAME (QUOTE NONE) (QUOTE OLD) (QUOTE HANDLE) (FUNCTION \NSFILING.FULLNAME) T)) STRIPPED-NAME) (if (NULL FULLNAME) then (NSPROT.PROMPT WINDOW "~A not found." (if (NSPROT.DIRECTORY.SYNTAXP FILENAME) then "Directory" elseif (STRPOS ">" FILENAME) then (* ; "Looks like a file") "File" else (* ; "Could be either if they were sloppy") "Directory/file")) NIL else (SETQ STRIPPED-NAME (CDR (NSPROT.STRIP.HOST FULLNAME))) (if (NOT (STREQUAL STRIPPED-NAME FILENAME)) then (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) STRIPPED-NAME WINDOW)) (if (NOT (NSPROT.DIRECTORY.SYNTAXP FULLNAME)) then (* ; "Force Principal protection, since non-directories don't have a default access list.") (NSPROT.RESTORE.TYPE WINDOW)) FULLNAME)))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "Handle protection submenus")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(NSPROT.GET.SUBMENU
|
||||
(LAMBDA (MAINWINDOW) (* ; "Edited 26-Aug-87 18:03 by bvm:") (LET ((SUBW (WINDOWPROP MAINWINDOW (QUOTE SCRATCHMENUS))) HEIGHT) (if SUBW then (* ; "Return a cached window to avoid overhead of creating a whole new freemenu. Don't forget to clear the old one out!") (PROG1 (NSPROT.CHANGE.STATE (CAR SUBW) NIL) (WINDOWPROP MAINWINDOW (QUOTE SCRATCHMENUS) (CDR SUBW))) else (SETQ SUBW (FREEMENU (BQUOTE ((PROPS FONT (\, (NSPROT.GET.FONT)) COLUMNSPACE 5) ((LABEL "Read" ID READ TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Read: User may read (if a file) or enumerate (if a directory)") (LABEL "Wrt" ID WRITE TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Write: User may write/change/delete the file.") (LABEL "Add" ID ADD TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Add: User can create files in the directory.") (LABEL "Del" ID REMOVE TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Delete: User can remove files from the directory.") (LABEL "Own" ID OWNER TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Owner: User can change the protection.") (LABEL "All" ID ALL TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.ALL MESSAGE NSPROT.MESSAGE.ALL) (LABEL " to:" ID TO TYPE EDITSTART MESSAGE "Fill in name (user or group) or pattern (*:Domain)." FONT (\, (NSPROT.GET.FONT T)) LINKS (EDIT NAME)) (LABEL (\, (CONCAT)) TYPE EDIT ID NAME)))) NIL NIL 3)) (WINDOWPROP SUBW (QUOTE FM.DONTRESHAPE) T) (* ; "Don't want any extra space added between columns when the window gets wider--add it all on the right.") (WINDOWPROP SUBW (QUOTE MINSIZE) (CONS 0 (SETQ HEIGHT (fetch (REGION HEIGHT) of (WINDOWPROP SUBW (QUOTE REGION)))))) (WINDOWPROP SUBW (QUOTE MAXSIZE) (CONS MAX.SMALLP HEIGHT)) (WINDOWPROP SUBW (QUOTE FM.PROMPTWINDOW) (GETPROMPTWINDOW MAINWINDOW)) SUBW)))
|
||||
)
|
||||
|
||||
(NSPROT.ADD.SUBMENU
|
||||
(LAMBDA (MENUW MAINWINDOW) (* ; "Edited 20-Aug-87 10:13 by bvm:") (* ;; "Appends MENUW to MAINWINDOW's set of protection value entries") (ATTACHWINDOW MENUW MAINWINDOW (QUOTE BOTTOM)) (WINDOWPROP MAINWINDOW (QUOTE PROTMENUS) (CONS MENUW (WINDOWPROP MAINWINDOW (QUOTE PROTMENUS)))))
|
||||
)
|
||||
|
||||
(NSPROT.REMOVE.SUBMENUS
|
||||
(LAMBDA (WINDOW) (* ; "Edited 24-Aug-87 12:34 by bvm:") (* ;; "Removes all the submenus (protection entries) from WINDOW, adding them to the scratch list for the window.") (LET ((OLDWINDOWS (WINDOWPROP WINDOW (QUOTE PROTMENUS) NIL))) (for W in OLDWINDOWS do (DETACHWINDOW W) (CLOSEW W)) (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS) (APPEND OLDWINDOWS (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS))))))
|
||||
)
|
||||
|
||||
(NSPROT.CHANGE.STATE
|
||||
(LAMBDA (WINDOW NEWSTATE) (* ; "Edited 19-Aug-87 16:15 by bvm:") (* ;; "Change all the protection buttons to the specified state") (for ID in (QUOTE (READ WRITE ADD REMOVE OWNER ALL)) do (FM.CHANGESTATE (FM.GETITEM ID NIL WINDOW) NEWSTATE WINDOW)) WINDOW)
|
||||
)
|
||||
|
||||
(NSPROT.HANDLE.ALL
|
||||
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 19-Aug-87 16:16 by bvm:") (* ;; "Called when ALL is selected--turn all protection bits to the specified state") (NSPROT.CHANGE.STATE WINDOW (FM.ITEMPROP ITEM (QUOTE STATE))))
|
||||
)
|
||||
|
||||
(NSPROT.MESSAGE.ALL
|
||||
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 20-Aug-87 14:15 by bvm:") (* ;; "Called when ALL is held--return appropriate help message") (if (FM.ITEMPROP ITEM (QUOTE STATE)) then "Deny user all access rights" else "Grant user all 5 access rights"))
|
||||
)
|
||||
|
||||
(NSPROT.HANDLE.SUBTYPE
|
||||
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 19-Aug-87 14:46 by bvm:") (LET ((OTHER (FM.GETITEM (QUOTE ALL) NIL WINDOW))) (if (FM.ITEMPROP OTHER (QUOTE STATE)) then (* ; "If the ALL button was on, turn it off") (FM.CHANGESTATE OTHER NIL WINDOW)) (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) ((WRITE ADD) (* ; "these accesses really need READ as well") (if (AND (FM.ITEMPROP ITEM (QUOTE STATE)) (NOT (FM.ITEMPROP (SETQ OTHER (FM.GETITEM (QUOTE READ) NIL WINDOW)) (QUOTE STATE)))) then (FM.CHANGESTATE OTHER T WINDOW))) NIL)))
|
||||
)
|
||||
|
||||
(NSPROT.SHOW.PROT.VALUE
|
||||
(LAMBDA (ENTRY MAINWINDOW) (* ; "Edited 24-Aug-87 16:16 by bvm:") (DESTRUCTURING-BIND (NAME TYPES) ENTRY (LET ((SUBW (NSPROT.GET.SUBMENU MAINWINDOW)) (STRINGNAME (NSNAME.TO.STRING NAME T)) ITEM) (for P in TYPES do (FM.CHANGESTATE (OR (SETQ ITEM (FM.GETITEM P NIL SUBW)) (HELP "Bad protection value" P)) T SUBW) (if (EQ P (QUOTE ALL)) then (NSPROT.HANDLE.ALL ITEM SUBW))) (FM.CHANGELABEL (FM.GETITEM (QUOTE NAME) NIL SUBW) STRINGNAME SUBW) (WINDOWPROP SUBW (QUOTE KNOWN-VALUE) (CONS STRINGNAME ENTRY)) (* ; "Save the parse of this value so we can avoid worrying about it later.") (NSPROT.ADD.SUBMENU SUBW MAINWINDOW) SUBW)))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "utilities")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(NSPROT.DIRECTORY.SYNTAXP
|
||||
(LAMBDA (FILENAME) (* ; "Edited 27-Aug-87 14:53 by bvm:") (* ; "True if FILENAME looks like a directory") (EQ (NTHCHARCODE FILENAME -1) (CHARCODE ">")))
|
||||
)
|
||||
|
||||
(NSPROT.TOP.LEVELP
|
||||
(LAMBDA (FILESPEC) (* ; "Edited 20-Nov-87 12:26 by bvm:") (LET (I) (NOT (AND (SETQ I (STRPOS ">" FILESPEC)) (NEQ I (NCHARS FILESPEC))))))
|
||||
)
|
||||
|
||||
(NSPROT.GET.FONT
|
||||
(LAMBDA (BOLDP) (* ; "Edited 1-Sep-87 17:23 by bvm:") (if BOLDP then (OR NSPROT.BOLD.FONT (SETQ NSPROT.BOLD.FONT (FONTCOPY (NSPROT.GET.FONT) (QUOTE WEIGHT) (QUOTE BOLD)))) elseif NSPROT.PLAIN.FONT elseif (> (FONTHEIGHT (SETQ NSPROT.PLAIN.FONT (FONTCREATE (QUOTE MODERN) 10))) 12) then (* ; "Yes, this is the one I had in mind (10 pt coerced to 12)") NSPROT.PLAIN.FONT else (* ; "The %"real%" 12 pt display font is about the right size.") (SETQ NSPROT.PLAIN.FONT (FONTCREATE (QUOTE MODERN) 12))))
|
||||
)
|
||||
|
||||
(NSPROT.PROMPT
|
||||
(LAMBDA WINDOW&ARGS (* ; "Edited 2-Aug-89 17:10 by bvm") (LET* ((*PRINT-CASE* :UPCASE) (MAINW (ARG WINDOW&ARGS 1)) (WINDOW (GETPROMPTWINDOW MAINW)) (ARGS (for J from (if (EQ (ARG WINDOW&ARGS 2) T) then (* ; "First arg of T means clear window first.") (NSPROT.CLEAR.PROMPT MAINW WINDOW) 3 else 2) to WINDOW&ARGS collect (ARG WINDOW&ARGS J)))) (RESETFORM (TTYDISPLAYSTREAM WINDOW) (* ; "Unfortunately, have to make it the tty to get pagefullfn action.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW ARGS)) NIL))
|
||||
)
|
||||
|
||||
(NSPROT.CLEAR.PROMPT
|
||||
(LAMBDA (MAINW PW) (* ; "Edited 2-Aug-89 17:14 by bvm") (* ;; "Clear's FOLDER's prompt window, and shrinks it back to a single line if it has grown") (LET ((PROP (WINDOWPROP MAINW (QUOTE PROMPTWINDOW))) (IDEALHEIGHT (OR (WINDOWPROP MAINW (QUOTE PROMPTLINES)) 1)) HEIGHT) (* ;; "PROP = (promptwindow . #lines)") (if (AND PROP (> (CDR PROP) IDEALHEIGHT)) then (* ; "Window has grown, so shape it back down") (SETQ HEIGHT (HEIGHTIFWINDOW (TIMES IDEALHEIGHT (FONTPROP PW (QUOTE HEIGHT))))) (WINDOWPROP PW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (* ; "have to adjust the fixed size of the window before shaping, since SHAPEW obeys the minimum.") (WINDOWPROP PW (QUOTE MAXSIZE) (CONS 64000 HEIGHT)) (SHAPEW PW (create REGION using (WINDOWPROP PW (QUOTE REGION)) HEIGHT _ HEIGHT)) (RPLACD PROP IDEALHEIGHT) (* ; "Clear it last to get coordinates right.")) (CLEARW PW)))
|
||||
)
|
||||
|
||||
(NSPROT.LIMITCHARS
|
||||
(LAMBDA (ITEM WINDOW CHAR) (* ; "Edited 21-Aug-87 12:00 by bvm:") (SELECTQ CHAR ((%
|
||||
Â) (FM.SKIPNEXT WINDOW) NIL) T)))
|
||||
|
||||
(NSPROT.PAGEFULLFN
|
||||
(LAMBDA (PW) (* ; "Edited 2-Aug-89 16:19 by bvm") (* ;; "PAGEFULLFN for prompt window--makes the window a line bigger and allows output to proceed") (SETQ \CURRENTDISPLAYLINE (PROG1 \#DISPLAYLINES (GETPROMPTWINDOW (MAINWINDOW PW) (+ 1 \#DISPLAYLINES)) (* ; "\Currentdisplayline is the line we're on when window fills, origin zero"))))
|
||||
)
|
||||
|
||||
(NSPROT.ICONFN
|
||||
(LAMBDA (WINDOW OLDICON) (* ; "Edited 1-Sep-87 10:29 by bvm:") (LET ((HOST (FM.ITEMPROP (FM.GETITEM (QUOTE HOST) NIL WINDOW) (QUOTE LABEL)))) (SETQ HOST (if (AND HOST (NEQ (NCHARS HOST) 0) (SETQ HOST (PARSE.NSNAME HOST))) then (fetch NSOBJECT of HOST) else "")) (* ; "show host's main name") (if OLDICON then (ICONW.TITLE OLDICON HOST) OLDICON else (TITLEDICONW NSPROT.ICON HOST (NSPROT.GET.FONT)))))
|
||||
)
|
||||
)
|
||||
|
||||
(RPAQ? NSPROT.PLAIN.FONT NIL)
|
||||
|
||||
(RPAQ? NSPROT.BOLD.FONT NIL)
|
||||
|
||||
(RPAQQ NSPROT.ICON (#*(80 40)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@AN@@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@GH@G@CL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@O@@CHCL@@@@@@@@@@@@@O@@CHCLAOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLAOOOOOOOOOOOOO@@CHCL@GNGNGN@@@@@@O@@CHCL@GNGNGN@@@@@@O@@CHCL@GNFFGN@@@@@@GH@GHCL@FFFFGN@@@@@@GH@GHCL@FF@@GN@@@@@@GH@G@CL@@@@@FF@@@@@@CL@O@CL@@@@@FF@@@@@@CL@O@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@CO@@CL@@@@@@@@@@@@@@@L@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO NIL (4 22 51 14)))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON \DEFAULTTTYDISPLAYSTREAM)
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(LOCALVARS . T)
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM))
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(ADD.NSPROTECTION
|
||||
(LAMBDA (LST) (* ; "Edited 2-Sep-87 11:53 by bvm:") (* ;; "Add an entry for the NSPROTECTION tool to the background menu") (for X in (if LST then (* ; "Mumbling thru sub items") (CDR LST) else (SETQ LST BackgroundMenuCommands)) bind (COM _ (QUOTE ("NS Protection" (QUOTE (NSPROTECTION)) "Start up the NS File protection tool."))) do (if (STRING-EQUAL (CAR X) "NS Protection") then (RETURN (RPLACD X (CDR COM))) elseif (AND (STRING-EQUAL (CAR X) "System") (CADDDR X)) then (RETURN (ADD.NSPROTECTION (CADDDR X)))) finally (NCONC1 LST COM)) (SETQ BackgroundMenu NIL) (* ; "also, load fonts") (NSPROT.GET.FONT T) (COND ((CCODEP (QUOTE ADD.NSPROTECTION)) (* ; "self destruct") (AND (PUTD (QUOTE ADD.NSPROTECTION))))))
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(ADD.NSPROTECTION)
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA)
|
||||
|
||||
(ADDTOVAR NLAML)
|
||||
|
||||
(ADDTOVAR LAMA NSPROT.PROMPT)
|
||||
)
|
||||
(PUTPROPS NSPROTECTION COPYRIGHT ("Xerox Corporation" 1987 1989))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1695 14166 (NSPROTECTION 1705 . 4891) (NSPROT.SHOW 4893 . 5411) (
|
||||
NSPROT.FETCH.PROTECTION 5413 . 8347) (NSPROT.NEW.ENTRY 8349 . 8972) (NSPROT.APPLY 8974 . 9903) (
|
||||
NSPROT.SET.PROTECTION 9905 . 10481) (NSPROT.SET.PROTECTION.ONE 10483 . 11359) (NSPROT.SET.MULTIPLE
|
||||
11361 . 12860) (NSPROT.SET.TO.DEFAULT 12862 . 13674) (NSPROT.BEGIN.COMMAND 13676 . 14164)) (14167
|
||||
21199 (NSPROT.HANDLE.TYPE 14177 . 14477) (NSPROT.RESTORE.TYPE 14479 . 14830) (NSPROT.HANDLE.VERIFY
|
||||
14832 . 15192) (NSPROT.RESTORE.VERIFY 15194 . 15525) (NSPROT.PARSE.FILENAME 15527 . 17256) (
|
||||
NSPROT.PARSE.PROTECTIONS 17258 . 19753) (NSPROT.STRIP.HOST 19755 . 20136) (NSPROT.EXPAND.FULLNAME
|
||||
20138 . 21197)) (21243 25794 (NSPROT.GET.SUBMENU 21253 . 23057) (NSPROT.ADD.SUBMENU 23059 . 23366) (
|
||||
NSPROT.REMOVE.SUBMENUS 23368 . 23788) (NSPROT.CHANGE.STATE 23790 . 24072) (NSPROT.HANDLE.ALL 24074 .
|
||||
24316) (NSPROT.MESSAGE.ALL 24318 . 24590) (NSPROT.HANDLE.SUBTYPE 24592 . 25137) (
|
||||
NSPROT.SHOW.PROT.VALUE 25139 . 25792)) (25821 29042 (NSPROT.DIRECTORY.SYNTAXP 25831 . 26015) (
|
||||
NSPROT.TOP.LEVELP 26017 . 26179) (NSPROT.GET.FONT 26181 . 26700) (NSPROT.PROMPT 26702 . 27226) (
|
||||
NSPROT.CLEAR.PROMPT 27228 . 28111) (NSPROT.LIMITCHARS 28113 . 28254) (NSPROT.PAGEFULLFN 28256 . 28616)
|
||||
(NSPROT.ICONFN 28618 . 29040)) (30249 30998 (ADD.NSPROTECTION 30259 . 30996)))))
|
||||
STOP
|
||||
File diff suppressed because one or more lines are too long
2946
lispusers/PLOT.~2~
2946
lispusers/PLOT.~2~
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
@@ -1,183 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED " 6-Nov-92 09:25:48" {DSK}<project>medley2.0>lispusers>READBRUSH.;1 9607
|
||||
|
||||
previous date%: "23-Jun-88 02:13:42" {DSK}<import>lisp>medley>lispusers>readbrush.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT READBRUSHCOMS)
|
||||
|
||||
(RPAQQ READBRUSHCOMS
|
||||
((FNS CHOOSE.IDLE.BITMAP READBRUSHFILE READBRUSH READROOTPICTURE IDLE.GLIDING.BOX)
|
||||
(FILES BITMAPFNS)
|
||||
[ADDVARS (IDLE.FUNCTIONS ("Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen"
|
||||
(SUBITEMS ("Pick image from MesaHacks" (PROGN (
|
||||
CHOOSE.IDLE.BITMAP
|
||||
)
|
||||
|
||||
'
|
||||
IDLE.GLIDING.BOX
|
||||
]
|
||||
(INITVARS (IDLE.BITMAP)
|
||||
(BRUSHMENU)
|
||||
(ROOTPICTUREMENU)
|
||||
(BRUSHDIRECTORY "{goofy:osbu north:xerox}<hacks>data>brushes>"))))
|
||||
(DEFINEQ
|
||||
|
||||
(CHOOSE.IDLE.BITMAP
|
||||
[LAMBDA NIL (* ; "Edited 23-Jun-88 01:51 by masinter")
|
||||
(PROG NIL
|
||||
(ALLOW.BUTTON.EVENTS)
|
||||
(SETQ IDLE.BOUNCING.BOX
|
||||
(CAR (READBRUSHFILE (OR [MENU (OR BRUSHMENU
|
||||
(SETQ BRUSHMENU
|
||||
(create MENU
|
||||
ITEMS _ (for FILE
|
||||
infiles (
|
||||
DIRECTORY.FILL.PATTERN
|
||||
BRUSHDIRECTORY
|
||||
"brush" "")
|
||||
collect (NAMEFIELD FILE]
|
||||
(RETURN])
|
||||
|
||||
(READBRUSHFILE
|
||||
[LAMBDA (FILE) (* lmm "23-Jul-86 21:26")
|
||||
(OR (AND (LITATOM FILE)
|
||||
(GET FILE 'BRUSH))
|
||||
(PROG ((STR (OPENSTREAM (PACKFILENAME.STRING 'BODY FILE 'DIRECTORY BRUSHDIRECTORY
|
||||
'EXTENSION
|
||||
'BRUSH)
|
||||
'INPUT
|
||||
'OLD))
|
||||
M W H BM MASK REG)
|
||||
(BIN STR)
|
||||
(SETQ M (SELECTQ (BIN STR)
|
||||
(1 T)
|
||||
(0 NIL)
|
||||
NIL))
|
||||
(SETQ W (BIN16 STR))
|
||||
(SETQ H (BIN16 STR))
|
||||
(RPTQ 10 (BIN STR))
|
||||
(SETQ BM (READBINARYBITMAP W H STR))
|
||||
(if M
|
||||
then (SETQ MASK (READBINARYBITMAP W H STR)))
|
||||
(CLOSEF STR)
|
||||
(SETQ BM (CONS BM MASK))
|
||||
(IF (LITATOM FILE)
|
||||
THEN (PUT FILE 'BRUSH BM))
|
||||
(RETURN BM])
|
||||
|
||||
(READBRUSH
|
||||
[LAMBDA (FILE) (* lmm " 4-Aug-85 07:31")
|
||||
(PROG ((BMS (READBRUSHFILE FILE))
|
||||
WIN REG)
|
||||
(if (CDR BMS)
|
||||
then (SETQ WIN (ICONW (CAR BMS)
|
||||
(CDR BMS)))
|
||||
else (MOVEW (SETQ WIN (CREATEWFROMIMAGE (CAR BMS)))
|
||||
[fetch (REGION LEFT) of (SETQ REG (GETBOXREGION
|
||||
(WINDOWPROP WIN 'WIDTH)
|
||||
(WINDOWPROP WIN 'HEIGHT]
|
||||
(fetch (REGION BOTTOM) of REG))
|
||||
(OPENW WIN))
|
||||
(WINDOWPROP WIN 'BUTTONEVENTFN 'MOVEW)
|
||||
(RETURN WIN])
|
||||
|
||||
(READROOTPICTURE
|
||||
[LAMBDA (FILE) (* edited%: "17-May-85 19:21")
|
||||
(CHANGEBACKGROUND (READPRESS (PACKFILENAME.STRING 'BODY FILE 'DIRECTORY
|
||||
"{GOOFY:OSBU NORTH}<HACKS>DATA>ROOTPICTURES>" 'EXTENSION
|
||||
'PRESS])
|
||||
|
||||
(IDLE.GLIDING.BOX
|
||||
[LAMBDA (WIN BITMAPS WAIT WAITSEQ MAXD) (* ; "Edited 23-Jun-88 01:53 by masinter")
|
||||
(OR BITMAPS (SETQ BITMAPS IDLE.BOUNCING.BOX))
|
||||
[OR WIN (SETQ WIN (OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW]
|
||||
(OR MAXD (SETQ MAXD 4))
|
||||
[SETQ BITMAPS (for X inside BITMAPS
|
||||
collect (if (LITATOM X)
|
||||
then [OR (GETPROP X 'BITMAP)
|
||||
(PUTPROP X 'BITMAP (OR (CAR (READBRUSHFILE
|
||||
X))
|
||||
(BITMAPCREATE 10 10]
|
||||
else (IDLE.BITMAP NIL X]
|
||||
(LET ((W (for X in BITMAPS largest (BITMAPWIDTH X) finally (RETURN $$EXTREME)))
|
||||
(H (for X in BITMAPS largest (BITMAPHEIGHT X) finally (RETURN $$EXTREME)))
|
||||
(REG (DSPCLIPPINGREGION NIL WIN)))
|
||||
(LET ((XBM (BITMAPCREATE (PLUS MAXD MAXD W)
|
||||
(PLUS MAXD MAXD H)))
|
||||
(MAXX (MAX (DIFFERENCE (fetch WIDTH REG)
|
||||
(ADD1 W))
|
||||
10))
|
||||
(MAXY (MAX (DIFFERENCE (fetch HEIGHT REG)
|
||||
(ADD1 W))
|
||||
10))
|
||||
(MAXDD (FIX (SQRT MAXD)))
|
||||
X Y (CNT 0)
|
||||
DX DY STEPS NEWX NEWY REALX REALY ORIGX ORIGY TOY TOX THISBITMAP)
|
||||
(SETQ X (RAND 1 MAXX))
|
||||
(SETQ Y (RAND 1 MAXY))
|
||||
(BITBLT (SETQ THISBITMAP (CAR BITMAPS))
|
||||
NIL NIL WIN X Y NIL NIL NIL 'INVERT)
|
||||
(while T do [COND
|
||||
((ILEQ CNT 0)
|
||||
(SETQ ORIGX X)
|
||||
(SETQ ORIGY Y)
|
||||
(SETQ TOX (RAND 1 (SUB1 MAXX)))
|
||||
(SETQ TOY (RAND 1 (SUB1 MAXY)))
|
||||
(SETQ CNT (SETQ STEPS
|
||||
(QUOTIENT (PLUS (MAX (ABS (DIFFERENCE TOX X))
|
||||
(ABS (DIFFERENCE TOY Y)))
|
||||
MAXD -1)
|
||||
MAXD)))
|
||||
(QUOTIENT (PLUS (ABS (DIFFERENCE TOX X))
|
||||
STEPS -1)
|
||||
STEPS))
|
||||
(T (SETQ CNT (SUB1 CNT]
|
||||
(SETQ NEWX (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGX TOX))
|
||||
STEPS)
|
||||
TOX))
|
||||
(if (GREATERP (ABS (SETQ DX (DIFFERENCE NEWX X)))
|
||||
MAXD)
|
||||
then (SHOULDNT))
|
||||
(SETQ NEWY (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGY TOY))
|
||||
STEPS)
|
||||
TOY))
|
||||
(if (GREATERP (ABS (SETQ DY (DIFFERENCE NEWY Y)))
|
||||
MAXD)
|
||||
then (SHOULDNT))
|
||||
(BITBLT NIL NIL NIL XBM NIL NIL NIL NIL 'TEXTURE 'ERASE BLACKSHADE)
|
||||
(BITBLT THISBITMAP NIL NIL XBM MAXD MAXD NIL NIL NIL 'INVERT)
|
||||
(BITBLT THISBITMAP NIL NIL XBM (PLUS MAXD DX)
|
||||
(PLUS MAXD DY)
|
||||
NIL NIL NIL 'INVERT)
|
||||
(BITBLT XBM NIL NIL WIN (DIFFERENCE X MAXD)
|
||||
(DIFFERENCE Y MAXD)
|
||||
NIL NIL NIL 'INVERT)
|
||||
(add X DX)
|
||||
(add Y DY)
|
||||
(DISMISS WAIT])
|
||||
)
|
||||
|
||||
(FILESLOAD BITMAPFNS)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ["Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen"
|
||||
(SUBITEMS ("Pick image from MesaHacks" (PROGN (CHOOSE.IDLE.BITMAP
|
||||
)
|
||||
'IDLE.GLIDING.BOX])
|
||||
|
||||
(RPAQ? IDLE.BITMAP )
|
||||
|
||||
(RPAQ? BRUSHMENU )
|
||||
|
||||
(RPAQ? ROOTPICTUREMENU )
|
||||
|
||||
(RPAQ? BRUSHDIRECTORY "{goofy:osbu north:xerox}<hacks>data>brushes>")
|
||||
(PUTPROPS READBRUSH COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1988 1992))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1444 8940 (CHOOSE.IDLE.BITMAP 1454 . 2452) (READBRUSHFILE 2454 . 3500) (READBRUSH 3502
|
||||
. 4314) (READROOTPICTURE 4316 . 4655) (IDLE.GLIDING.BOX 4657 . 8938)))))
|
||||
STOP
|
||||
Binary file not shown.
@@ -1 +0,0 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
|
||||
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
@@ -1,662 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED "25-Jan-97 11:49:57" |{DSK}<project>medley2.0>lispusers>TMAX-NGROUP.;2| 47901
|
||||
|
||||
|changes| |to:| (FNS CONVERT.TABS.TO.SPACES)
|
||||
|
||||
|previous| |date:| "30-Dec-87 11:34:27" |{DSK}<project>medley2.0>lispusers>TMAX-NGROUP.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1997 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(PRETTYCOMPRINT TMAX-NGROUPCOMS)
|
||||
|
||||
(RPAQQ TMAX-NGROUPCOMS
|
||||
((* |Developed| |under| |support| |from| NIH |grant| RR-00785.)
|
||||
(* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|)
|
||||
(* * |Other| |unsorted| |functions|)
|
||||
(FNS INSERT.NGROUP VERIFY.NGROUP.ORDER GET.PREVIOUS.NGROUPS ADD.NUMBER.GROUP
|
||||
ADD.NGROUP.TO.DBASE COLLECT.NGROUPS LIST.FONT.PROPS MAP.NGROUP.LOOKS NGROUP.GETFONT
|
||||
CHANGE.NGROUP CHANGE.NGROUP.FONT SHOW.NGROUP.FONT CHANGE.NGROUP.FORMAT
|
||||
SHOW.NGROUP.FORMAT CHANGE.NGROUP.FORMAT.TXTBEFORE CHANGE.NGROUP.FORMAT.DISPLAY
|
||||
CHANGE.NGROUP.FORMAT.TXTAFTER GET.NGROUP.DELIMITER CHANGE.NGROUP.FORMAT.ABBREV
|
||||
CHANGE.NGROUP.FORMAT.START GET.NGROUP.START CHANGE.NGROUP.FORMAT.TOC
|
||||
CHANGE.NGROUP.FORMAT.MANINDEX UPDATE.NGROUP.MANINDEX NGROUP.FIXUP.RECORDS)
|
||||
(* * |Table-of-Contents| |functions|)
|
||||
(FNS GET.NGROUP.TEXTSTRING CONVERT.TABS.TO.SPACES CREATE.TOC.FILE NGROUP.TOC.ENTRIES
|
||||
VIEW.TOC.FILE GET.TOC.FILE WRITE.TOC.FILE WRITE.TOC.ENTRY)))
|
||||
|
||||
|
||||
|
||||
(* |Developed| |under| |support| |from| NIH |grant| RR-00785.)
|
||||
|
||||
|
||||
|
||||
|
||||
(* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|)
|
||||
|
||||
(* * |Other| |unsorted| |functions|)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(insert.ngroup
|
||||
(lambda (node graphw) (* |fsg| "26-Aug-87 14:37")
|
||||
(* * |Insert| \a |NGroup| |build| |from| |the| |prototype| |definition.|)
|
||||
|
||||
(and node (let* ((twindow (windowprop graphw 'twindow))
|
||||
(tstream (windowprop graphw 'tstream))
|
||||
(label (|fetch| (graphnode nodeid) |of| node))
|
||||
(oldlooks (|fetch| caretlooks |of| (textobj tstream)))
|
||||
(newlooks (ngroup.getfont label twindow)))
|
||||
(|with| numberobj (car (gethash label (tsp.get.ngroup.array twindow)))
|
||||
(selectq label
|
||||
(new.ngroup nil)
|
||||
(let ((newobj (numberobj 'ngroup template (concat "[" label "]")
|
||||
label newlooks (get.fromnodes label twindow)
|
||||
abbrev-val)))
|
||||
(tedit.caretlooks tstream newlooks)
|
||||
(get.ngroup.textstring newobj label tstream twindow)
|
||||
(imageobjprop newobj 'twindow twindow)
|
||||
(tedit.insert.object newobj tstream)
|
||||
(tedit.caretlooks tstream oldlooks)
|
||||
(and (update? twindow)
|
||||
(update.numberobjs twindow tstream 'ngroupp))
|
||||
(verify.ngroup.order twindow newobj))))))))
|
||||
|
||||
(verify.ngroup.order
|
||||
(lambda (window ngroup.obj) (* |fsg| "28-Jul-87 15:59")
|
||||
(* * |Verify| |the| |NGroup| |order| |before| |inserting| \a |new| |NGroup.|
|
||||
|The| |order| |is| |valid| |if| |the| |new| |NGroup| |is| \a |top| |level|
|
||||
|node| |or| |its| |parent| |Ngroup| |has| |already| |been| |inserted.|)
|
||||
|
||||
(let* ((mother (|with| numberobj (|fetch| objectdatum |of| ngroup.obj)
|
||||
ngroup.mother))
|
||||
(selection (tedit.getsel (textstream window)))
|
||||
(ch# (and selection (|fetch| ch# |of| selection))))
|
||||
(cond
|
||||
((or (eq mother 'new.ngroup)
|
||||
(and ch# (|for| prev.ngroup |in| (tsp.list.of.objects (textobj window)
|
||||
(function get.previous.ngroups)
|
||||
ch#)
|
||||
|thereis| (eq mother (|with| numberobj (|fetch| objectdatum
|
||||
|of| (car prev.ngroup))
|
||||
ref.type)))))
|
||||
(tedit.promptprint (textstream window)
|
||||
"" t))
|
||||
(t (tedit.promptprint (textstream window)
|
||||
(concat "Warning...\"" (|with| numberobj (|fetch| objectdatum |of| ngroup.obj)
|
||||
ref.type)
|
||||
"\" is not preceded by \"" mother "\" NGroup.")
|
||||
t)
|
||||
(flashwindow (|with| textobj (textobj window)
|
||||
promptwindow)
|
||||
2))))))
|
||||
|
||||
(get.previous.ngroups
|
||||
(lambda (ngroup.obj char.pos) (* |fsg| "28-Jul-87 14:01")
|
||||
(* * |Called| |from| tsp.list.of.objects |to| |collect| |all| |the| |NGroup|
|
||||
|ImageObjs| |that| |exist| |before| |the| |character| |position| char.pos.)
|
||||
|
||||
(and (ngroupp ngroup.obj)
|
||||
(ilessp ch# char.pos))))
|
||||
|
||||
(add.number.group
|
||||
(lambda (twindow stream) (* \; "Edited 30-Sep-87 14:34 by fsg")
|
||||
|
||||
(or (ngroupmenu.enabled? twindow)
|
||||
(progn (fm.changestate (fm.getitem 'ngroup.menu nil (windowprop twindow 'imageobj.menuw))
|
||||
t
|
||||
(windowprop twindow 'imageobj.menuw))
|
||||
(graphmenu stream twindow)))
|
||||
(let* ((prev.items (collect.ngroups twindow))
|
||||
(new.groupid (mkatom (tsp.legalid (cons 'new.ngroup prev.items)
|
||||
stream)))
|
||||
template dependent.class new.node)
|
||||
(prog1 (cond
|
||||
(new.groupid (setq dependent.class
|
||||
(or (mkatom (and prev.items
|
||||
(menu (|create| menu
|
||||
title _ "Parent Group?"
|
||||
items _ (sort prev.items 'ualphorder)
|
||||
))))
|
||||
'new.ngroup))
|
||||
(or template
|
||||
(setq template
|
||||
(|create| ngtemplate
|
||||
ng.chartype _ '|Number|
|
||||
ng.text-before _ nil
|
||||
ng.text-after _ "."
|
||||
ng.start _ 1
|
||||
ng.addtotoc _ t
|
||||
ng.currentval _ nil
|
||||
ng.manualindex _ nil)))
|
||||
(setq new.node (nodecreate new.groupid new.groupid nil nil (list
|
||||
dependent.class
|
||||
)))
|
||||
(add.ngroup.to.dbase new.groupid template dependent.class |GP.DefaultFont|
|
||||
new.node twindow)
|
||||
(add.node.to.graph new.node (windowprop twindow 'ngroup.graph)
|
||||
twindow))
|
||||
(t nil))
|
||||
(tedit.promptprint stream "" t)))))
|
||||
|
||||
(add.ngroup.to.dbase
|
||||
(lambda (new.groupid template dependent.class font ngroup.node twindow)
|
||||
(* |fsg| " 3-Aug-87 16:43")
|
||||
(let ((ngroup.array (tsp.get.ngroup.array twindow)))
|
||||
(or (gethash new.groupid ngroup.array)
|
||||
(progn (windowprop twindow 'rebuild.graphflg t)
|
||||
(puthash new.groupid
|
||||
(list (|create| numberobj
|
||||
ngroup.mother _ dependent.class
|
||||
font _ font
|
||||
ref.type _ new.groupid
|
||||
template _ template)
|
||||
ngroup.node)
|
||||
(list ngroup.array)))))))
|
||||
|
||||
(collect.ngroups
|
||||
(lambda (twindow) (* |ss:| "31-Mar-86 13:53")
|
||||
(let ((graph (windowprop twindow 'ngroup.graph)))
|
||||
(|for| node |in| (|fetch| (graph graphnodes) |of| graph) |collect| (|fetch| (graphnode
|
||||
nodeid)
|
||||
|of| node)
|
||||
|unless| (eq (|fetch| (graphnode nodeid) |of| node)
|
||||
'new.ngroup)))))
|
||||
|
||||
(list.font.props
|
||||
(lambda (fontdes) (* |fsg| " 3-Aug-87 10:03")
|
||||
(and (fontp fontdes)
|
||||
(list (fontprop fontdes 'family)
|
||||
(fontprop fontdes 'size)
|
||||
(fontprop fontdes 'face)))))
|
||||
|
||||
(map.ngroup.looks
|
||||
(lambda (label new.font twindow new.template) (* |fsg| " 5-Aug-87 13:40")
|
||||
(* * |Here| |to| |change| |the| |font| |or| |format| |of| |an| |NGroup.|
|
||||
i\f new.template |is| |non-NIL| |then| |we| |are| |changing| |the| |format,|
|
||||
|else| |we| |are| |changing| |the| |font.|)
|
||||
|
||||
(tedit.promptprint (textstream twindow)
|
||||
(concat "Updating " (cond
|
||||
(new.template "FORMAT")
|
||||
(t "FONT"))
|
||||
" for \"" label "\" Ngroups...")
|
||||
t)
|
||||
(|for| ngroup.obj |in| (tsp.list.of.objects (textobj twindow)
|
||||
`(lambda (obj)
|
||||
(and (ngroupp obj)
|
||||
(eq (fetch ref.type of (fetch objectdatum of obj))
|
||||
\,
|
||||
(kwote label)))))
|
||||
|do| (|with| numberobj (|fetch| objectdatum |of| (car ngroup.obj))
|
||||
(cond
|
||||
(new.template (setq template new.template))
|
||||
(t (tedit.looks (textstream twindow)
|
||||
new.font
|
||||
(cadr ngroup.obj)
|
||||
1)
|
||||
(setq font new.font)))))
|
||||
(tedit.promptprint (textstream twindow)
|
||||
"Done.")))
|
||||
|
||||
(ngroup.getfont
|
||||
(lambda (ngroup.name window ngroup.obj) (* |fsg| " 4-Aug-87 15:00")
|
||||
(* * |Get| |an| |NGroup's| |font.| i\f ngroup.obj |is| |non-NIL| |then| |we|
|
||||
|get| |the| |font| |from| |this| |ImageObj's| objectdatum.
|
||||
|Else| |we| |get| |the| |font| |from| |the| |NGroup| |graph| |prototype|
|
||||
|NGroup.|)
|
||||
|
||||
(|fetch| (numberobj font) |of| (cond
|
||||
(ngroup.obj (|fetch| objectdatum |of| ngroup.obj))
|
||||
(t (car (gethash ngroup.name (tsp.get.ngroup.array window))))))
|
||||
))
|
||||
|
||||
(change.ngroup
|
||||
(lambda (node graphw) (* |fsg| "30-Jul-87 13:52")
|
||||
(* * |Here| |when| |number| |group| |node| |is| |middle| |buttoned.|
|
||||
|Allow| |user| |to| |change| |the| |font| |and/or| |format| |of| |the|
|
||||
|ngroup.|)
|
||||
|
||||
(and node (let ((label (|fetch| (graphnode nodeid) |of| node)))
|
||||
(selectq label
|
||||
(new.ngroup nil)
|
||||
(menu (|create| menu
|
||||
title _ (mkstring label)
|
||||
centerflg _ t
|
||||
items _ (eval ngroup.graph.menu.items))))))))
|
||||
|
||||
(change.ngroup.font
|
||||
(lambda (label graphw font.field ngroup.obj) (* |fsg| " 4-Aug-87 15:09")
|
||||
(* * |Change| \a |NGroup| |font.| i\f |NGROUP.OBJis| |non-NIL| |then| |we|
|
||||
|are| |working| |on| |an| |inserted| |NGroup.|
|
||||
|Else| |we| |are| |working| |on| |the| |graph| |prototype| |NGroups.|)
|
||||
|
||||
(let ((stream (windowprop graphw 'tstream))
|
||||
(window (windowprop graphw 'twindow))
|
||||
new.font)
|
||||
(show.ngroup.font label graphw ngroup.obj)
|
||||
(tedit.promptprint stream (selectq font.field
|
||||
(family ", change Family to...")
|
||||
(size ", change Size to...")
|
||||
(face ", change Face to...")
|
||||
", change to..."))
|
||||
(|with| numberobj (cond
|
||||
(ngroup.obj (|fetch| objectdatum |of| ngroup.obj))
|
||||
(t (car (gethash label (tsp.get.ngroup.array window)))))
|
||||
(setq new.font (fontcreate (get.tsp.font window font font.field)))
|
||||
(tedit.promptprint stream "" t)
|
||||
(and (neq font new.font)
|
||||
(progn (setq font new.font)
|
||||
(cond
|
||||
(ngroup.obj new.font)
|
||||
(t (map.ngroup.looks label new.font window)))))))))
|
||||
|
||||
(show.ngroup.font
|
||||
(lambda (label graphw ngroup.obj) (* |fsg| " 4-Aug-87 14:57")
|
||||
(* * |Show| |this| |NGroup's| |font| |specification.|)
|
||||
|
||||
(let* ((stream (windowprop graphw 'tstream))
|
||||
(window (windowprop graphw 'twindow))
|
||||
(font.list (abbreviate.font (ngroup.getfont label window ngroup.obj))))
|
||||
(tedit.promptprint stream (concat label ": Family=" (|pop| font.list)
|
||||
" Size="
|
||||
(|pop| font.list)
|
||||
" Face="
|
||||
(|pop| font.list))
|
||||
t))))
|
||||
|
||||
(change.ngroup.format
|
||||
(lambda (label graphw format.field) (* |fsg| " 1-Sep-87 15:39")
|
||||
(* * |Change| |the| |entire| |format| |or| \a |selected| |field| |of| |an|
|
||||
|NGroup.|)
|
||||
|
||||
(let ((window (windowprop graphw 'twindow))
|
||||
(new.format (|for| field |in| (cond
|
||||
(format.field (list format.field))
|
||||
(t '(txtbefore display txtafter abbrevval start toc
|
||||
manindex)))
|
||||
|collect| (selectq field
|
||||
(txtbefore (change.ngroup.format.txtbefore label graphw))
|
||||
(display (change.ngroup.format.display label graphw))
|
||||
(txtafter (change.ngroup.format.txtafter label graphw))
|
||||
(abbrevval (change.ngroup.format.abbrev label graphw))
|
||||
(start (change.ngroup.format.start label graphw))
|
||||
(toc (change.ngroup.format.toc label graphw))
|
||||
(manindex (change.ngroup.format.manindex label graphw))
|
||||
(error "Unknown NGroup Format field" field)))))
|
||||
(and (apply 'or new.format)
|
||||
(let ((nbrobj (car (gethash label (tsp.get.ngroup.array window)))))
|
||||
(map.ngroup.looks label (|fetch| (numberobj font) |of| nbrobj)
|
||||
window
|
||||
(|fetch| (numberobj template) |of| nbrobj)))))))
|
||||
|
||||
(show.ngroup.format
|
||||
(lambda (label graphw) (* |fsg| "26-Aug-87 12:02")
|
||||
(* * |Show| |this| |NGroup's| |format| |specification.|)
|
||||
|
||||
(let ((stream (windowprop graphw 'tstream))
|
||||
(window (windowprop graphw 'twindow)))
|
||||
(|with| numberobj (car (gethash label (tsp.get.ngroup.array window)))
|
||||
(|with| ngtemplate template (tedit.promptprint stream
|
||||
(concat label ": Display="
|
||||
(concat (cond
|
||||
(ng.text-before (concat "\""
|
||||
ng.text-before
|
||||
"\""))
|
||||
(t "\"\""))
|
||||
ng.chartype
|
||||
(cond
|
||||
(ng.text-after (concat "\""
|
||||
ng.text-after
|
||||
"\""))
|
||||
(t "\"\"")))
|
||||
" Abbrev="
|
||||
(or abbrev-val "None")
|
||||
" Start=" ng.start " TOC=" (cond
|
||||
(ng.addtotoc
|
||||
"Yes")
|
||||
(t "No"))
|
||||
(cond
|
||||
((manualindex.enabled? window)
|
||||
(cond
|
||||
(ng.manualindex " ManIndex=Yes")
|
||||
(t " ManIndex=No")))
|
||||
(t "")))
|
||||
t))))))
|
||||
|
||||
(change.ngroup.format.txtbefore
|
||||
(lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:11")
|
||||
(* * |Show| |and| |possibly| |reset| |the| |delimiter| |preceding| |this|
|
||||
|NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new|
|
||||
|delimiter.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on|
|
||||
|an| |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph|
|
||||
|prototype.|)
|
||||
|
||||
(let ((stream (windowprop graphw 'tstream))
|
||||
(window (windowprop graphw 'twindow))
|
||||
new.delimiter)
|
||||
(|with| ngtemplate (|fetch| (numberobj template) |of| (cond
|
||||
(ngroup.obj (|fetch| objectdatum
|
||||
|of| ngroup.obj))
|
||||
(t (car (gethash label (
|
||||
tsp.get.ngroup.array
|
||||
window)))))
|
||||
)
|
||||
(and (setq new.delimiter (get.ngroup.delimiter stream label ng.text-before
|
||||
'before))
|
||||
(not (strequal new.delimiter ng.text-before))
|
||||
(setq ng.text-before new.delimiter))))))
|
||||
|
||||
(change.ngroup.format.display
|
||||
(lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:12")
|
||||
(* * |Show| |and| |possibly| |reset| |how| |this| |NGroup| |is| |displayed.|
|
||||
|Return| nil |if| |nothing| |changed| |else| |returm| |the| |new| |display|
|
||||
|type.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on| |an|
|
||||
|inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph| |prototype.|)
|
||||
|
||||
(let ((stream (windowprop graphw 'tstream))
|
||||
(window (windowprop graphw 'twindow))
|
||||
new.display)
|
||||
(|with| ngtemplate (|fetch| (numberobj template) |of| (cond
|
||||
(ngroup.obj (|fetch| objectdatum
|
||||
|of| ngroup.obj))
|
||||
(t (car (gethash label (
|
||||
tsp.get.ngroup.array
|
||||
window)))))
|
||||
)
|
||||
(tedit.promptprint stream (concat "\"" label "\" displayed as " ng.chartype
|
||||
", change to...")
|
||||
t)
|
||||
(|until| (or (null (setq new.display
|
||||
(menu (|create| menu
|
||||
title _ "NGroup Displays"
|
||||
centerflg _ t
|
||||
items _ '(|Number| |Null String| uppercase\ letter
|
||||
|lowercase letter| uppercase\ roman
|
||||
|lowercase roman|)))))
|
||||
(selectq new.display
|
||||
((|Number| |Null String|)
|
||||
t)
|
||||
(igreaterp ng.start 0)))
|
||||
|do| (tedit.promptprint stream (concat "Starting value (=" ng.start
|
||||
") must be > 0 for \"" new.display
|
||||
"\". Try again.")
|
||||
t))
|
||||
(tedit.promptprint stream "" t)
|
||||
(and new.display (neq new.display ng.chartype)
|
||||
(kwote (setq ng.chartype new.display)))))))
|
||||
|
||||
(change.ngroup.format.txtafter
|
||||
(lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:12")
|
||||
(* * |Show| |and| |possibly| |reset| |the| |delimiter| |following| |this|
|
||||
|NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new|
|
||||
|delimiter.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on|
|
||||
|an| |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph|
|
||||
|prototype.|)
|
||||
|
||||
(let ((stream (windowprop graphw 'tstream))
|
||||
(window (windowprop graphw 'twindow))
|
||||
new.delimiter)
|
||||
(|with| ngtemplate (|fetch| (numberobj template) |of| (cond
|
||||
(ngroup.obj (|fetch| objectdatum
|
||||
|of| ngroup.obj))
|
||||
(t (car (gethash label (
|
||||
tsp.get.ngroup.array
|
||||
window)))))
|
||||
)
|
||||
(and (setq new.delimiter (get.ngroup.delimiter stream label ng.text-after
|
||||
'after))
|
||||
(not (strequal new.delimiter ng.text-after))
|
||||
(setq ng.text-after new.delimiter))))))
|
||||
|
||||
(get.ngroup.delimiter
|
||||
(lambda (stream label delimiter before/after) (* |fsg| "17-Aug-87 15:12")
|
||||
(* * |Show| |and| |possibly| |reset| |the| |delimiter| |before/after| |this|
|
||||
|NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new|
|
||||
|delimiter.|)
|
||||
|
||||
(tedit.promptprint stream (concat "Delimiter " (selectq before/after
|
||||
(before "preceding ")
|
||||
"following ")
|
||||
label "\" is " (cond
|
||||
(delimiter (concat "\"" delimiter "\""))
|
||||
(t '|Unspecified|))
|
||||
", change to...")
|
||||
t)
|
||||
(prog1 (menu (|create| menu
|
||||
title _ "NGroup Delimiters"
|
||||
centerflg _ t
|
||||
items _ '((|Period| ".")
|
||||
(|Colon| ":")
|
||||
(|Dash| "-")
|
||||
(|Null String| "")
|
||||
(|Other| (tedit.getinput stream (concat "Specify delimiter "
|
||||
(selectq before/after
|
||||
(before "preceding ")
|
||||
"following ")
|
||||
label ":"))))))
|
||||
(tedit.promptprint stream "" t))))
|
||||
|
||||
(change.ngroup.format.abbrev
|
||||
(lambda (label graphw ngroup.obj) (* |fsg| "26-Aug-87 11:48")
|
||||
(* * |Change| |the| |display| |level| |of| \a |NGroup.|
|
||||
|Let| |the| |user| |decide| |how| |far| |up| |the| |parent| |tree| |to| |go|
|
||||
|wrt| |printing| |values.| |This| |allows| |user| |to| |number| |things| |as|
|
||||
|2.a,| |b,| |c,| |etc.| |Thanks| |to| |Michael| |Wescoat| |at| |Xerox| |for|
|
||||
|suggesting| |this.|)
|
||||
|
||||
(let ((stream (windowprop graphw 'tstream))
|
||||
(window (windowprop graphw 'twindow)))
|
||||
(|with| numberobj (cond
|
||||
(ngroup.obj (|fetch| objectdatum |of| ngroup.obj))
|
||||
(t (car (gethash label (tsp.get.ngroup.array window)))))
|
||||
(let ((parents (list.ancestors label nil window)))
|
||||
(cond
|
||||
(parents (tedit.promptprint stream (concat label (cond
|
||||
(abbrev-val (concat
|
||||
|
||||
" abbreviation starts at "
|
||||
abbrev-val))
|
||||
(t " not abbreviated"))
|
||||
". Select starting level.")
|
||||
t)
|
||||
(let ((new.abrev (menu (|create| menu
|
||||
title _ (concat label " Levels")
|
||||
items _ (append parents (list label))
|
||||
centerflg _ t))))
|
||||
(and new.abrev (neq new.abrev abbrev-val)
|
||||
(true (setq abbrev-val (cond
|
||||
((eq new.abrev (car parents))
|
||||
nil)
|
||||
(t new.abrev)))))))
|
||||
(t (tedit.promptprint stream (concat "Cannot abbreviate top level NGroup \""
|
||||
label "\"")
|
||||
t))))))))
|
||||
|
||||
(change.ngroup.format.start
|
||||
(lambda (label graphw) (* |fsg| " 9-Jul-87 15:45")
|
||||
(* * |Show| |and| |possibly| |reset| |this| |NGroup's| |starting| |value.|
|
||||
|Return| nil |if| |nothing| |changed| |else| |return| |the| |new| |starting|
|
||||
|value.|)
|
||||
|
||||
(let ((window (windowprop graphw 'twindow))
|
||||
new.start)
|
||||
(|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label (
|
||||
tsp.get.ngroup.array
|
||||
window))))
|
||||
(and (setq new.start (get.ngroup.start label ng.chartype ng.start (windowprop
|
||||
graphw
|
||||
'tstream)))
|
||||
(neq new.start ng.start)
|
||||
(setq ng.start new.start))))))
|
||||
|
||||
(get.ngroup.start
|
||||
(lambda (label display start stream) (* |fsg| "23-Jul-87 14:38")
|
||||
(* * |Get| |the| |starting| |value| |for| |this| |NGroup.|
|
||||
|Any| |value| |is| |ok| |for| \a |Number| |display| |but| |Letter/Roman|
|
||||
|numeral| |values| |must| |be| |greater| |than| |zero.|)
|
||||
|
||||
(let ((prompt.string (concat "Starting value of \"" label "\" is " start))
|
||||
new.start)
|
||||
(|until| (or (null (setq new.start (mkatom (tedit.getinput stream (concat prompt.string
|
||||
". New starting value:"
|
||||
)))))
|
||||
(cond
|
||||
((not (fixp new.start))
|
||||
(setq prompt.string (concat new.start " is not an integer"))
|
||||
nil)
|
||||
(t (selectq display
|
||||
((|Number| |Null String|)
|
||||
t)
|
||||
(cond
|
||||
((ileq new.start 0)
|
||||
(setq prompt.string (concat "Start (=" new.start
|
||||
") must be > 0 for \"" display "\""))
|
||||
nil)
|
||||
(t t)))))))
|
||||
new.start)))
|
||||
|
||||
(change.ngroup.format.toc
|
||||
(lambda (label graphw) (* |fsg| " 7-Jul-87 09:12")
|
||||
(* * |Show| |and| |possibly| |reset| |whether| |this| |NGroup| |is| |included|
|
||||
|in| |the| |Table-Of¬Contents.| |Return| nil |if| |no| |change| |else| |return|
|
||||
t.)
|
||||
|
||||
(let ((stream (windowprop graphw 'tstream))
|
||||
(window (windowprop graphw 'twindow))
|
||||
new.addtotoc)
|
||||
(|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label (
|
||||
tsp.get.ngroup.array
|
||||
window))))
|
||||
(tedit.promptprint stream (concat "\"" label "\" is " (cond
|
||||
(ng.addtotoc "")
|
||||
(t "NOT "))
|
||||
"included in the TOC. Do you want it included?")
|
||||
t)
|
||||
(setq new.addtotoc (menu (|create| menu
|
||||
title _ "In TOC?"
|
||||
centerflg _ t
|
||||
items _ '((yes t)
|
||||
(no nil))
|
||||
whenselectedfn _ (function (lambda (item)
|
||||
item)))))
|
||||
(tedit.promptprint stream "" t)
|
||||
(and new.addtotoc (neq (cadr new.addtotoc)
|
||||
ng.addtotoc)
|
||||
(progn (setq ng.addtotoc (cadr new.addtotoc))
|
||||
t))))))
|
||||
|
||||
(change.ngroup.format.manindex
|
||||
(lambda (label graphw) (* |fsg| " 1-Sep-87 15:39")
|
||||
(* * |Show| |and| |possibly| |reset| |whether| |this| |NGroup| |is| |included|
|
||||
|in| |the| |manual| |index.| |Return| nil |if| |no| |change| |else| |return| t.)
|
||||
|
||||
(let ((stream (windowprop graphw 'tstream))
|
||||
(window (windowprop graphw 'twindow))
|
||||
new.manualindex)
|
||||
(and (manualindex.enabled? window)
|
||||
(|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label (
|
||||
tsp.get.ngroup.array
|
||||
window))))
|
||||
(tedit.promptprint stream (concat "\"" label "\" is " (cond
|
||||
(ng.manualindex "")
|
||||
(t "NOT"))
|
||||
|
||||
" included in the Manual Index. Do you want it included?"
|
||||
)
|
||||
t)
|
||||
(setq new.manualindex (menu (|create| menu
|
||||
title _ "Manual Index?"
|
||||
centerflg _ t
|
||||
items _ '((yes t)
|
||||
(no nil))
|
||||
whenselectedfn _ (function (lambda (item)
|
||||
item)))))
|
||||
(tedit.promptprint stream "" t)
|
||||
(and new.manualindex (neq (cadr new.manualindex)
|
||||
ng.manualindex)
|
||||
(true (cond
|
||||
((setq ng.manualindex (cadr new.manualindex))
|
||||
(windowaddprop window 'manualgroups label))
|
||||
(t (windowdelprop window 'manualgroups label))))))))))
|
||||
|
||||
(update.ngroup.manindex
|
||||
(lambda (template label window) (* |ss:| "27-Jun-87 16:22")
|
||||
(* * |Update| |the| |NGroup| |template| |list| |wrt| |the| |current| |NGroup|
|
||||
|level.| |Note| |that| |when| \a |new| |NGroup| |is| |seen,| |all| |it's|
|
||||
|children| |become| |undefined.| |Furthermore| |we| |know| |the| |NGroups|
|
||||
|are| |in| |order| |since| |the| |order| |is| |verified| |when| |the| |NGroup|
|
||||
|is| |inserted.|)
|
||||
|
||||
(and (manualindex.enabled? window)
|
||||
(let* ((man.groups (windowprop window 'manualgroups))
|
||||
(label.groups (memb label man.groups)))
|
||||
(and label.groups (let* ((label.offset (add1 (idifference (length man.groups)
|
||||
(length label.groups))))
|
||||
(man.templates (windowprop window 'manualtemplates))
|
||||
(template.sublist (nth man.templates label.offset)))
|
||||
(cond
|
||||
(template.sublist (rplnode template.sublist template))
|
||||
(t (windowaddprop window 'manualtemplates template)))))))))
|
||||
|
||||
(ngroup.fixup.records
|
||||
(lambda (ngroup.record copyflg) (* |fsg| " 3-Sep-87 15:35")
|
||||
(* * |Function| |to| "fix up" |the| |NGroup| |record.|
|
||||
|This| |allows| |us| |to| |expand| |the| |NGroup| |record| |and| |still|
|
||||
|maintain| |backwatd| |compatability.| i\f copyflg |is| |non-NIL,| |we| |are|
|
||||
|doing| \a copy. i\n |this| |case| |un-update| |the| |record;|
|
||||
|Copied| |NGroups| |are| |always| |unupdated.|)
|
||||
|
||||
(let ((template (|fetch| (numberobj template) |of| ngroup.record)))
|
||||
(|create| numberobj
|
||||
ref.type _ (|fetch| (numberobj ref.type) |of| ngroup.record)
|
||||
numstring _ (cond
|
||||
(copyflg (selectq (|fetch| (numberobj use) |of| ngroup.record)
|
||||
(ngroup (concat "[" (|fetch| (numberobj ref.type)
|
||||
|of| ngroup.record)
|
||||
"]"))
|
||||
(note "Note#")
|
||||
nil))
|
||||
(t (|fetch| (numberobj numstring) |of| ngroup.record)))
|
||||
use _ (|fetch| (numberobj use) |of| ngroup.record)
|
||||
ngroup.mother _ (|fetch| (numberobj ngroup.mother) |of| ngroup.record)
|
||||
template _ (|create| ngtemplate
|
||||
ng.chartype _ (|fetch| (ngtemplate ng.chartype) |of| template)
|
||||
ng.text-before _ (|fetch| (ngtemplate ng.text-before) |of| template
|
||||
)
|
||||
ng.text-after _ (|fetch| (ngtemplate ng.text-after) |of| template)
|
||||
ng.start _ (|fetch| (ngtemplate ng.start) |of| template)
|
||||
ng.addtotoc _ (|fetch| (ngtemplate ng.addtotoc) |of| template)
|
||||
ng.currentval _ (cond
|
||||
(copyflg nil)
|
||||
(t (|fetch| (ngtemplate ng.currentval)
|
||||
|of| template)))
|
||||
ng.manualindex _ (|fetch| (ngtemplate ng.manualindex) |of| template
|
||||
))
|
||||
updated.obj _ (cond
|
||||
(copyflg nil)
|
||||
(t (|fetch| (numberobj updated.obj) |of| ngroup.record)))
|
||||
text.after# _ (|fetch| (numberobj text.after#) |of| ngroup.record)
|
||||
page.number _ (|fetch| (numberobj page.number) |of| ngroup.record)
|
||||
font _ (|fetch| (numberobj font) |of| ngroup.record)
|
||||
text.before# _ (|fetch| (numberobj text.before#) |of| ngroup.record)
|
||||
abbrev-val _ (|fetch| (numberobj abbrev-val) |of| ngroup.record)))))
|
||||
)
|
||||
(* * |Table-of-Contents| |functions|)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(get.ngroup.textstring
|
||||
(lambda (nbrobj label stream window) (* |fsg| " 5-Aug-87 10:36")
|
||||
(* * |Get| |the| |Table-Of-Contents| |before/after| |text| |string| |for|
|
||||
|this| |NGroup.| |Because| |the| write.toc.file |function| |uses| \a |tab| |to|
|
||||
|align| |the| |page| |numbers,| |any| |tabs| |in| |the| toc |strings| |are|
|
||||
|converted| |to| |spaces.|)
|
||||
|
||||
(and (textbefore.enabled? window)
|
||||
(let ((toc.string (tedit.getinput stream (concat "Text before " label ":")
|
||||
(mkstring label))))
|
||||
(and toc.string (|replace| (numberobj text.before#) |of| (|fetch| objectdatum
|
||||
|of| nbrobj)
|
||||
|with| (concat (convert.tabs.to.spaces toc.string)
|
||||
" ")))))
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -1 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
@@ -1,9 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "13-Jul-99 10:05:38" {DSK}<project>medley3.5>lispusers>WDWHACKS.;3 6218
|
||||
|
||||
changes to%: (VARS WDWHACKSCOMS)
|
||||
(FNS Filebrowsericide)
|
||||
|
||||
previous date%: " 1-Dec-96 21:15:33" {DSK}<project>medley3.5>lispusers>WDWHACKS.;2)
|
||||
|
||||
|
||||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
@@ -1,654 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "18-Nov-93 14:43:00" {DSK}<king>export>lispcore>lispusers>comparetext.;2 39517
|
||||
|
||||
changes to%: (VARS COMPARETEXTCOMS)
|
||||
|
||||
previous date%: "11-Jul-85 09:12:06" {DSK}<king>export>lispcore>lispusers>comparetext.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1984, 1985, 1993 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COMPARETEXTCOMS)
|
||||
|
||||
(RPAQQ COMPARETEXTCOMS
|
||||
((DECLARE%: EVAL@COMPILE (FILES (LOADCOMP)
|
||||
GRAPHER))
|
||||
(FNS COMPARETEXT IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS
|
||||
IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH IMCOMPARE.FIND.TEDIT.TEXT.OBJECT IMCOMPARE.HASH
|
||||
IMCOMPARE.LEFTBUTTONFN IMCOMPARE.LENGTHEN.ATOM IMCOMPARE.MERGE.CONNECTED.CHUNKS
|
||||
IMCOMPARE.MERGE.UNCONNECTED.CHUNKS IMCOMPARE.MIDDLEBUTTONFN IMCOMPARE.SHOW.DIST
|
||||
IMCOMPARE.UPDATE.SYMBOL.TABLE)
|
||||
(P (MOVD 'COMPARETEXT 'IMCOMPARE))
|
||||
(VARS (IMCOMPARE.LAST.NODE NIL)
|
||||
(IMCOMPARE.LAST.GRAPH.WINDOW NIL)
|
||||
(IMCOMPARE.HASH.TYPE.MENU NIL))
|
||||
(RECORDS IMCOMPARE.CHUNK IMCOMPARE.SYMB)
|
||||
(FILES GRAPHER)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
GRAPHER)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(COMPARETEXT
|
||||
[LAMBDA (NEWFILENAME OLDFILENAME HASH.TYPE GRAPH.REGION)
|
||||
(* mjs " 8-Jan-84 21:06")
|
||||
|
||||
(* Compares the two files, and produces a graph showing their corresponding
|
||||
chunks. The courseness of the "chunking" is determined by HASH.TYPE, which may
|
||||
be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA.
|
||||
The file difference graph is displayed at GRAPHREGION.
|
||||
If GRAPH.REGION = NIL, the user is asked to specify a region.
|
||||
If GRAPH.REGION = T, a standard region is used.)
|
||||
|
||||
(PROG ((NEWFILE (FINDFILE NEWFILENAME T))
|
||||
(OLDFILE (FINDFILE OLDFILENAME T)))
|
||||
(if (AND OLDFILE NEWFILE)
|
||||
then (* compare the two "chunks"
|
||||
consisting of the entire text of the
|
||||
two files)
|
||||
(IMCOMPARE.CHUNKS (create IMCOMPARE.CHUNK
|
||||
FILENAME _ NEWFILE
|
||||
FILEPTR _ 0
|
||||
CHUNKLENGTH _ (GETFILEINFO NEWFILE 'LENGTH))
|
||||
(create IMCOMPARE.CHUNK
|
||||
FILENAME _ OLDFILE
|
||||
FILEPTR _ 0
|
||||
CHUNKLENGTH _ (GETFILEINFO OLDFILE 'LENGTH))
|
||||
HASH.TYPE
|
||||
(if (EQ GRAPH.REGION T)
|
||||
then (create REGION
|
||||
LEFT _ 25
|
||||
BOTTOM _ 25
|
||||
WIDTH _ 500
|
||||
HEIGHT _ 150)
|
||||
elseif GRAPH.REGION
|
||||
else (CLRPROMPT)
|
||||
(printout PROMPTWINDOW
|
||||
"Please specify a window for the file difference graph" T)
|
||||
(GETREGION)))
|
||||
else (printout T "Can't find both files: " NEWFILENAME " & " OLDFILENAME
|
||||
" --- IMCOMPARE aborted" T])
|
||||
|
||||
(IMCOMPARE.BOXNODE
|
||||
[LAMBDA (NODE WINDOW) (* rmk%: "14-Dec-84 13:40")
|
||||
(if IMCOMPARE.LAST.NODE
|
||||
then (RESET/NODE/BORDER IMCOMPARE.LAST.NODE 'INVERT IMCOMPARE.LAST.GRAPH.WINDOW)
|
||||
(SETQ IMCOMPARE.LAST.NODE NIL)
|
||||
(SETQ IMCOMPARE.LAST.GRAPH.WINDOW NIL))
|
||||
(if NODE
|
||||
then (RESET/NODE/BORDER NODE 'INVERT WINDOW)
|
||||
(SETQ IMCOMPARE.LAST.NODE NODE)
|
||||
(SETQ IMCOMPARE.LAST.GRAPH.WINDOW WINDOW])
|
||||
|
||||
(IMCOMPARE.CHUNKS
|
||||
[LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION)
|
||||
(* rmk%: " 8-Sep-84 00:06")
|
||||
|
||||
(* this is the main text-comparison function.
|
||||
It compares the text in the two chunks <which may be small pieces of files, or
|
||||
entire files> and produces a graph showing how the sub-chunks of the two main
|
||||
chunks are related. The two main chunks may be in the same file, and the file
|
||||
may actually be an open Tedit textstream.
|
||||
The main chunks are broken down according to HASH.TYPE, which may be PARA
|
||||
<chunk by paragraph>, LINE, or WORD. HASH.TYPE = NIL defaults to PARA.
|
||||
The file difference graph is displayed at GRAPH.REGION.)
|
||||
|
||||
(* this text comparison algorithm is originally from the article
|
||||
"A Technique for Isolating Differences Between Files" by Paul Heckel, in CACM,
|
||||
V21, %#4, April 1978 --- major difference is that I use lists instead of arrays)
|
||||
|
||||
(PROG ((CHUNK.SYMBOL.TABLE (HASHARRAY 500))
|
||||
NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST)
|
||||
|
||||
(* * collect lists of chunks from each of the main chunks, dividing them
|
||||
according to HASH.TYPE)
|
||||
|
||||
(SETQ NEWFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS NEWFILE.SPEC.CHUNK HASH.TYPE))
|
||||
(SETQ OLDFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS OLDFILE.SPEC.CHUNK HASH.TYPE))
|
||||
|
||||
(* * update the chunk symbol table. For each hash value, this table records the
|
||||
number of "new" chunks with that hash value, the number of "old" chunks with
|
||||
that value, and a pointer to the place in OLD.CHUNK.LIST <not to an OLD chunk
|
||||
itself>.)
|
||||
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE NEWFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE NIL)
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE OLDFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE T)
|
||||
|
||||
(* * For every new chunk whose hash value matches EXACTLY ONE old chunk's
|
||||
value, "connect" it to the old chunk by setting the new chunk's OTHERCHUNK
|
||||
field to point to the appropriate place in the old chunk list <not the old
|
||||
chunk directly>. Also, make sure that OTHERCHUNK of the matching old chunk is
|
||||
non-NIL, so that unconnected old chunks will be merged correctly.)
|
||||
|
||||
(for NEW.CHUNK in NEWFILE.CHUNK.LIST bind SYMB
|
||||
do (SETQ SYMB (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of NEW.CHUNK)
|
||||
CHUNK.SYMBOL.TABLE))
|
||||
(if (AND (EQ 1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB))
|
||||
(EQ 1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB)))
|
||||
then (replace (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK
|
||||
with (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB))
|
||||
(replace (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of (CAR (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB))
|
||||
with T)))
|
||||
|
||||
(* * merge connected chunks forward)
|
||||
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST NIL)
|
||||
|
||||
(* * merge connected chunks backwards)
|
||||
|
||||
(SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
|
||||
(SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST T)
|
||||
(SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
|
||||
(SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
|
||||
|
||||
(* * merge unconnected chunks)
|
||||
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS NEWFILE.CHUNK.LIST)
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS OLDFILE.CHUNK.LIST)
|
||||
|
||||
(* * now, the file comparison is complete.
|
||||
Format and display the file difference graph)
|
||||
|
||||
(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK
|
||||
HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST])
|
||||
|
||||
(IMCOMPARE.COLLECT.HASH.CHUNKS
|
||||
[LAMBDA (CHUNK HASH.TYPE) (* mjs " 8-Jan-84 20:57")
|
||||
|
||||
(* * returns a list of the chunks in CHUNK as hashed of type HASH.TYPE)
|
||||
|
||||
(PROG ((FILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK))
|
||||
STREAM END.OF.CHUNK.PTR CHUNK.LIST)
|
||||
[SETQ STREAM (GETSTREAM (OPENFILE FILENAME 'INPUT 'OLD]
|
||||
(SETFILEPTR STREAM (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK))
|
||||
(SETQ END.OF.CHUNK.PTR (IPLUS (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)))
|
||||
(SETQ CHUNK.LIST (until (IGEQ (GETFILEPTR STREAM)
|
||||
END.OF.CHUNK.PTR) collect (IMCOMPARE.HASH STREAM
|
||||
END.OF.CHUNK.PTR
|
||||
HASH.TYPE)))
|
||||
(CLOSEF STREAM)
|
||||
(RETURN CHUNK.LIST])
|
||||
|
||||
(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH
|
||||
[LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST
|
||||
OLDFILE.CHUNK.LIST) (* mjs "11-Jul-85 09:10")
|
||||
|
||||
(* * format and display the graph)
|
||||
|
||||
(PROG ((NEWFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of NEWFILE.SPEC.CHUNK))
|
||||
(OLDFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of OLDFILE.SPEC.CHUNK))
|
||||
(OLD.CHUNK.NODE.FROM.NODES NIL)
|
||||
(BORDERSIZE 1)
|
||||
GRAPH.WINDOW NEW.CHUNK.NODES OLD.CHUNK.NODES OLD.CHUNK.XCOORD NEW.CHUNK.XCOORD
|
||||
YCOORD.INCREMENT DIFF.GRAPH)
|
||||
|
||||
(* * set up GRAPH.WINDOW. This is done first so you can get the width and
|
||||
height of strings to be printed in the window.)
|
||||
|
||||
[SETQ GRAPH.WINDOW (CREATEW GRAPH.REGION (CONCAT "Text File Differences, hashed by "
|
||||
(SELECTQ HASH.TYPE
|
||||
((PARA NIL)
|
||||
"Paragraph")
|
||||
(LINE "Line")
|
||||
(WORD "Word")
|
||||
(SHOULDNT]
|
||||
(WINDOWPROP GRAPH.WINDOW 'IMPARE.HASH.TYPE HASH.TYPE)
|
||||
[WINDOWADDPROP GRAPH.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW)
|
||||
(if (EQ WINDOW
|
||||
IMCOMPARE.LAST.GRAPH.WINDOW)
|
||||
then (SETQ
|
||||
IMCOMPARE.LAST.GRAPH.WINDOW
|
||||
NIL)
|
||||
(SETQ IMCOMPARE.LAST.NODE NIL]
|
||||
(SETQ NEW.CHUNK.XCOORD (IQUOTIENT (STRINGWIDTH NEWFILENAME GRAPH.WINDOW)
|
||||
2))
|
||||
[SETQ OLD.CHUNK.XCOORD (IPLUS NEW.CHUNK.XCOORD (IMAX 100 (IPLUS NEW.CHUNK.XCOORD
|
||||
(IQUOTIENT (STRINGWIDTH
|
||||
OLDFILENAME
|
||||
GRAPH.WINDOW)
|
||||
2)
|
||||
20]
|
||||
[SETQ YCOORD.INCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE)
|
||||
(fetch (REGION HEIGHT) of (STRINGREGION
|
||||
NEWFILENAME
|
||||
GRAPH.WINDOW]
|
||||
|
||||
(* * collect new-chunk graph nodes, while accumulating
|
||||
OLD.CHUNK.NODE.FROM.NODES, assoc list from old-chunks to new-chunks)
|
||||
|
||||
(SETQ NEW.CHUNK.NODES (for NEW.CHUNK in NEWFILE.CHUNK.LIST as Y from
|
||||
YCOORD.INCREMENT
|
||||
by YCOORD.INCREMENT bind CORRESPONDING.OLD.CHUNK
|
||||
collect (SETQ CORRESPONDING.OLD.CHUNK
|
||||
(CAR (fetch (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of NEW.CHUNK)))
|
||||
(if CORRESPONDING.OLD.CHUNK
|
||||
then (SETQ OLD.CHUNK.NODE.FROM.NODES
|
||||
(CONS (CONS CORRESPONDING.OLD.CHUNK NEW.CHUNK)
|
||||
OLD.CHUNK.NODE.FROM.NODES)))
|
||||
(* Start out with 2 point white
|
||||
border, so we can invert it)
|
||||
(NODECREATE NEW.CHUNK (IMCOMPARE.LENGTHEN.ATOM
|
||||
(PACK* (fetch (IMCOMPARE.CHUNK
|
||||
FILEPTR)
|
||||
of NEW.CHUNK)
|
||||
":"
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of NEW.CHUNK))
|
||||
12)
|
||||
(create POSITION
|
||||
XCOORD _ NEW.CHUNK.XCOORD
|
||||
YCOORD _ Y)
|
||||
(if CORRESPONDING.OLD.CHUNK
|
||||
then (LIST CORRESPONDING.OLD.CHUNK)
|
||||
else NIL)
|
||||
NIL DEFAULTFONT -2)))
|
||||
(SETQ OLD.CHUNK.NODES (for OLD.CHUNK in OLDFILE.CHUNK.LIST as Y from
|
||||
YCOORD.INCREMENT
|
||||
by YCOORD.INCREMENT bind CORRESPONDING.NEW.CHUNK
|
||||
collect (SETQ CORRESPONDING.NEW.CHUNK (CDR (ASSOC OLD.CHUNK
|
||||
OLD.CHUNK.NODE.FROM.NODES
|
||||
)))
|
||||
(NODECREATE OLD.CHUNK (IMCOMPARE.LENGTHEN.ATOM
|
||||
(PACK* (fetch (IMCOMPARE.CHUNK
|
||||
FILEPTR)
|
||||
of OLD.CHUNK)
|
||||
":"
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of OLD.CHUNK))
|
||||
12 "-")
|
||||
(create POSITION
|
||||
XCOORD _ OLD.CHUNK.XCOORD
|
||||
YCOORD _ Y)
|
||||
NIL
|
||||
(if CORRESPONDING.NEW.CHUNK
|
||||
then (LIST CORRESPONDING.NEW.CHUNK)
|
||||
else NIL)
|
||||
DEFAULTFONT -2)))
|
||||
(SETQ DIFF.GRAPH (create GRAPH
|
||||
DIRECTEDFLG _ T
|
||||
SIDESFLG _ T
|
||||
GRAPHNODES _
|
||||
(NCONC (LIST (NODECREATE NEWFILE.SPEC.CHUNK NEWFILENAME
|
||||
(create POSITION
|
||||
XCOORD _ NEW.CHUNK.XCOORD
|
||||
YCOORD _ 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
NEW.CHUNK.NODES
|
||||
(LIST (NODECREATE OLDFILE.SPEC.CHUNK OLDFILENAME
|
||||
(create POSITION
|
||||
XCOORD _ OLD.CHUNK.XCOORD
|
||||
YCOORD _ 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
OLD.CHUNK.NODES)))
|
||||
(SHOWGRAPH DIFF.GRAPH GRAPH.WINDOW (FUNCTION IMCOMPARE.LEFTBUTTONFN)
|
||||
(FUNCTION IMCOMPARE.MIDDLEBUTTONFN)
|
||||
T NIL])
|
||||
|
||||
(IMCOMPARE.FIND.TEDIT.TEXT.OBJECT
|
||||
[LAMBDA (FILE) (* mjs " 2-Jan-84 16:19")
|
||||
|
||||
(* returns the Tedit text object of the first Tedit window which is currently
|
||||
looking at FILE, if there is one. Returns NIL if none is found.)
|
||||
|
||||
(PROG ((TEDIT.TEXT.OBJECT NIL))
|
||||
(for X in (OPENWINDOWS) bind POSS.TOBJ POSS.FILENAME
|
||||
when (SETQ POSS.TOBJ (WINDOWPROP X 'TEXTOBJ)) repeatuntil TEDIT.TEXT.OBJECT
|
||||
do (SETQ POSS.FILENAME (FULLNAME (fetch (TEXTOBJ TXTFILE) of POSS.TOBJ)))
|
||||
(if (EQ FILE POSS.FILENAME)
|
||||
then (SETQ TEDIT.TEXT.OBJECT POSS.TOBJ)))
|
||||
(RETURN TEDIT.TEXT.OBJECT])
|
||||
|
||||
(IMCOMPARE.HASH
|
||||
[LAMBDA (STREAM EOF.PTR HASH.TYPE) (* rmk%: " 8-Sep-84 00:37")
|
||||
|
||||
(* reads caracters from STREAM and creates a hash value for the "next" "chunk"
|
||||
A chunk is a paragraph ending in two consecutive CRs <HASH.TYPE = NIL or PARA>,
|
||||
a line ending in a CR <HASH.TYPE = LINE>, or a word ending in any white space
|
||||
character space <HASH.TYPE = WORD>. In computing the hash value, white space is
|
||||
ignored. IMCOMPARE.HASH automatically stops before reading char number EOF.PTR
|
||||
Returns an IMCOMPARE.CHUNK containing the hash value, the file pointer of the
|
||||
beginning of the chunk, the length of the chunk, and the fullname of the stream)
|
||||
|
||||
(* Note%: Most of the time in COMPARETEXT is spent reading in and hashing
|
||||
chunks, so this function was optimizes for speed, at the expense of length)
|
||||
|
||||
(PROG ((BEGIN.FILE.PTR (GETFILEPTR STREAM))
|
||||
(EOLC (GETFILEINFO STREAM 'EOL))
|
||||
(HASHNUM 0)
|
||||
FILE.PTR C)
|
||||
(SETQ FILE.PTR BEGIN.FILE.PTR)
|
||||
(SELECTQ HASH.TYPE
|
||||
((NIL PARA)
|
||||
|
||||
(* Paragraph chunks end with two consecutive EOL's.
|
||||
In order to detect this without slowing down the gobbling of normal chars,
|
||||
LAST.EOL.POS is set to the filepos of the last EOL detected.
|
||||
This is only checked when another EOL comes along.)
|
||||
|
||||
(PROG ((LAST.EOL.POS -5))
|
||||
loop
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (SETQ C (BIN STREAM))
|
||||
(CR
|
||||
|
||||
(* If this is the second consecutive CR, this is the end of the chunk.
|
||||
Otherwise, reset LAST.EOL.POS)
|
||||
|
||||
(SELECTQ EOLC
|
||||
(CR (if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM)))
|
||||
then (GO endchunk)
|
||||
else (SETQ LAST.EOL.POS (GETFILEPTR STREAM))))
|
||||
(CRLF (if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SELCHARQ (\PEEKBIN STREAM T)
|
||||
(LF (SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(BIN STREAM)
|
||||
(if (IEQP LAST.EOL.POS (IDIFFERENCE
|
||||
(GETFILEPTR STREAM)
|
||||
2))
|
||||
then (GO endchunk)
|
||||
else (SETQ LAST.EOL.POS (GETFILEPTR STREAM
|
||||
))))
|
||||
NIL))
|
||||
NIL))
|
||||
(LF [COND
|
||||
((EQ EOLC 'LF)
|
||||
(if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM)))
|
||||
then (GO endchunk)
|
||||
else (SETQ LAST.EOL.POS (GETFILEPTR STREAM])
|
||||
((SPACE TAB))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16)))
|
||||
(GO loop)))
|
||||
(LINE (* Line chunks end on a single CR.)
|
||||
(PROG NIL
|
||||
loop
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (SETQ C (BIN STREAM))
|
||||
(CR (SELECTQ EOLC
|
||||
(CR (GO endchunk))
|
||||
(LF)
|
||||
(CRLF (if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SELCHARQ (\PEEKBIN STREAM T)
|
||||
(LF (SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(BIN STREAM)
|
||||
(GO endchunk))
|
||||
NIL))
|
||||
(SHOULDNT)))
|
||||
(LF (AND (EQ EOLC 'LF)
|
||||
(GO endchunk)))
|
||||
((SPACE TAB))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16)))
|
||||
(GO loop)))
|
||||
(WORD (* word chunks end on any white
|
||||
space)
|
||||
(PROG NIL
|
||||
loop
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (SETQ C (BIN STREAM))
|
||||
((CR SPACE TAB LF)
|
||||
(GO endchunk))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16)))
|
||||
(GO loop)))
|
||||
(SHOULDNT))
|
||||
endchunk
|
||||
(* flush all white space before next
|
||||
chunk)
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (BIN STREAM)
|
||||
((CR SPACE TAB LF)
|
||||
(GO endchunk))
|
||||
(PROGN (SETQ FILE.PTR (SUB1 FILE.PTR))
|
||||
(SETFILEPTR STREAM FILE.PTR)))
|
||||
return
|
||||
(RETURN (create IMCOMPARE.CHUNK
|
||||
HASHVALUE _ HASHNUM
|
||||
FILEPTR _ BEGIN.FILE.PTR
|
||||
CHUNKLENGTH _ (IDIFFERENCE FILE.PTR BEGIN.FILE.PTR)
|
||||
FILENAME _ (FULLNAME STREAM])
|
||||
|
||||
(IMCOMPARE.LEFTBUTTONFN
|
||||
[LAMBDA (GNODE WINDOW) (* mjs " 2-Apr-85 14:21")
|
||||
(if GNODE
|
||||
then (IMCOMPARE.BOXNODE GNODE WINDOW)
|
||||
(PROG ((NODEID (fetch (GRAPHNODE NODEID) of GNODE))
|
||||
(FILEPTR 1)
|
||||
(CHUNKLENGTH 0)
|
||||
(TEDIT.TEXT.OBJECT NIL)
|
||||
FILE)
|
||||
(SETQ FILE (fetch (IMCOMPARE.CHUNK FILENAME) of NODEID))
|
||||
(SETQ FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of NODEID))
|
||||
(SETQ CHUNKLENGTH (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NODEID))
|
||||
(SETQ TEDIT.TEXT.OBJECT (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT FILE))
|
||||
(if TEDIT.TEXT.OBJECT
|
||||
then (TEDIT.SETSEL TEDIT.TEXT.OBJECT (IMAX 1 (IDIFFERENCE FILEPTR 25))
|
||||
0
|
||||
'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
|
||||
(TEDIT.SETSEL TEDIT.TEXT.OBJECT FILEPTR CHUNKLENGTH 'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
|
||||
(TTY.PROCESS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of
|
||||
|
||||
TEDIT.TEXT.OBJECT
|
||||
))
|
||||
'PROCESS))
|
||||
else (TEDIT FILE NIL NIL (LIST 'SEL (LIST FILEPTR CHUNKLENGTH])
|
||||
|
||||
(IMCOMPARE.LENGTHEN.ATOM
|
||||
[LAMBDA (X MIN.LENGTH EXTENDER) (* mjs "30-Dec-83 15:11")
|
||||
|
||||
(* makes sure that the atom X is at least MIN.LENGTH characters long, by
|
||||
concatinating the first character of EXTENDER
|
||||
(or space, if not given) to the front)
|
||||
|
||||
(PROG ((C (CHCON X)))
|
||||
(SETQ EXTENDER (if EXTENDER
|
||||
then (CHCON1 EXTENDER)
|
||||
else (CHARCODE SPACE)))
|
||||
(while (ILESSP (LENGTH C)
|
||||
MIN.LENGTH) do (SETQ C (CONS EXTENDER C)))
|
||||
(RETURN (PACKC C])
|
||||
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS
|
||||
[LAMBDA (NEW.CHUNK.LIST BACKWARDS.FLG) (* mjs " 6-Jan-84 10:35")
|
||||
(while NEW.CHUNK.LIST bind NEW.CHUNK OLD.CHUNK.PTR
|
||||
do (SETQ NEW.CHUNK (CAR NEW.CHUNK.LIST))
|
||||
(SETQ OLD.CHUNK.PTR (fetch (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK))
|
||||
(if [OR (NULL (CDR NEW.CHUNK.LIST))
|
||||
(NULL OLD.CHUNK.PTR)
|
||||
(NULL (CDR OLD.CHUNK.PTR))
|
||||
(NOT (EQP (fetch (IMCOMPARE.CHUNK HASHVALUE) of (CADR NEW.CHUNK.LIST
|
||||
))
|
||||
(fetch (IMCOMPARE.CHUNK HASHVALUE) of (CADR OLD.CHUNK.PTR]
|
||||
then (SETQ NEW.CHUNK.LIST (CDR NEW.CHUNK.LIST))
|
||||
else
|
||||
|
||||
(* next chunks have same hash, so "murge" them into current chunks by adding
|
||||
their chunk lengths to the current chunks, and splicing out the next chunks)
|
||||
|
||||
[replace (IMCOMPARE.CHUNK CHUNKLENGTH) of NEW.CHUNK
|
||||
with (IPLUS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NEW.CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CADR
|
||||
NEW.CHUNK.LIST
|
||||
]
|
||||
[replace (IMCOMPARE.CHUNK CHUNKLENGTH) of (CAR OLD.CHUNK.PTR)
|
||||
with (IPLUS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CAR
|
||||
OLD.CHUNK.PTR
|
||||
))
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CADR
|
||||
OLD.CHUNK.PTR
|
||||
]
|
||||
[if BACKWARDS.FLG
|
||||
then (* if the list is backwards, copy
|
||||
next fileptr)
|
||||
(replace (IMCOMPARE.CHUNK FILEPTR) of NEW.CHUNK
|
||||
with (fetch (IMCOMPARE.CHUNK FILEPTR) of (CADR
|
||||
NEW.CHUNK.LIST
|
||||
)))
|
||||
(replace (IMCOMPARE.CHUNK FILEPTR) of (CAR OLD.CHUNK.PTR)
|
||||
with (fetch (IMCOMPARE.CHUNK FILEPTR) of (CADR
|
||||
OLD.CHUNK.PTR
|
||||
]
|
||||
(* splice chunks out of new and old
|
||||
list)
|
||||
(RPLACD NEW.CHUNK.LIST (CDDR NEW.CHUNK.LIST))
|
||||
(RPLACD OLD.CHUNK.PTR (CDDR OLD.CHUNK.PTR])
|
||||
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS
|
||||
[LAMBDA (CHUNK.LST) (* mjs " 5-JAN-84 13:58")
|
||||
(while CHUNK.LST bind CHUNK do (SETQ CHUNK (CAR CHUNK.LST))
|
||||
(if (OR (NULL (CDR CHUNK.LST))
|
||||
(fetch (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of (CADR CHUNK.LST)))
|
||||
then (SETQ CHUNK.LST (CDR CHUNK.LST))
|
||||
else (* both current chunk and next chunk
|
||||
have no OTHERCHUNK, so merge them)
|
||||
[replace (IMCOMPARE.CHUNK CHUNKLENGTH)
|
||||
of CHUNK
|
||||
with (IPLUS (fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of (CADR CHUNK.LST]
|
||||
(* splice chunks out of new and old
|
||||
list)
|
||||
(RPLACD CHUNK.LST (CDDR CHUNK.LST])
|
||||
|
||||
(IMCOMPARE.MIDDLEBUTTONFN
|
||||
[LAMBDA (GNODE WINDOW) (* mjs " 6-Jan-84 11:37")
|
||||
|
||||
(* This function is called if the MIDDLE mouse button is pressed over a graph
|
||||
node. The selected node is IMCOMPARE-ed with the last node selected <which is
|
||||
boxed>. The type of hashing used <PARA, LINE, or WORD> is selected from a
|
||||
pop-up menu. If none of the hashing types is selected, the current node is
|
||||
boxed. The pop-up menu is always located a little above the current cursor
|
||||
position, so a quick double-MIDDLE-click is an easy way to change the current
|
||||
boxed node.)
|
||||
|
||||
(if GNODE
|
||||
then (PROG (INNER.HASH.TYPE)
|
||||
(CLRPROMPT)
|
||||
(printout PROMPTWINDOW "Please select the type of hashing you wish." T)
|
||||
[SETQ INNER.HASH.TYPE
|
||||
(MENU (if (type? MENU IMCOMPARE.HASH.TYPE.MENU)
|
||||
then IMCOMPARE.HASH.TYPE.MENU
|
||||
else (SETQ IMCOMPARE.HASH.TYPE.MENU
|
||||
(create MENU
|
||||
ITEMS _ '(PARA LINE WORD)
|
||||
MENUOFFSET _
|
||||
(create POSITION
|
||||
XCOORD _ 20
|
||||
YCOORD _ -20]
|
||||
(if (NULL INNER.HASH.TYPE)
|
||||
then (* if no hash type is selected, just
|
||||
box the current node and return)
|
||||
(IMCOMPARE.BOXNODE GNODE WINDOW)
|
||||
(RETURN))
|
||||
(if (NULL IMCOMPARE.LAST.NODE)
|
||||
then (CLRPROMPT)
|
||||
(PRIN1 "You must select another graph node first." PROMPTWINDOW)
|
||||
(RETURN))
|
||||
(printout PROMPTWINDOW "Comparing chunks by " INNER.HASH.TYPE T)
|
||||
(IMCOMPARE.CHUNKS (fetch (GRAPHNODE NODEID) of IMCOMPARE.LAST.NODE
|
||||
)
|
||||
(fetch (GRAPHNODE NODEID) of GNODE)
|
||||
INNER.HASH.TYPE
|
||||
(WINDOWPROP WINDOW 'REGION])
|
||||
|
||||
(IMCOMPARE.SHOW.DIST
|
||||
[LAMBDA (LST MAX) (* mjs "30-Dec-83 15:13")
|
||||
(PROG ((WINDOW (CREATEW))
|
||||
MAX.Y X MAX.X)
|
||||
(SETQ MAX.X (WINDOWPROP WINDOW 'WIDTH))
|
||||
(SETQ MAX.Y (WINDOWPROP WINDOW 'HEIGHT))
|
||||
(for SAMPLE in LST do (SETQ X (FTIMES MAX.X (FQUOTIENT SAMPLE MAX)))
|
||||
(DRAWLINE X 0 X MAX.Y 1 'PAINT WINDOW])
|
||||
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE
|
||||
[LAMBDA (CHUNK.LIST CHUNK.SYMBOL.TABLE OLD.CHUNK.FLG) (* mjs " 8-Jan-84 21:01")
|
||||
|
||||
(* * update the chunk symbol table. For each hash value, this table records the
|
||||
number of "new" chunks with that hash value, the number of "old" chunks with
|
||||
that value, and a pointer to the place in OLD.CHUNK.LIST <not to an OLD chunk
|
||||
itself>.)
|
||||
|
||||
(for CHUNK.PTR on CHUNK.LIST bind CHUNK SYMB
|
||||
do (SETQ CHUNK (CAR CHUNK.PTR))
|
||||
(SETQ SYMB (if (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of CHUNK)
|
||||
CHUNK.SYMBOL.TABLE)
|
||||
else (PUTHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of CHUNK)
|
||||
(create IMCOMPARE.SYMB
|
||||
NEWCOUNT _ 0
|
||||
OLDCOUNT _ 0
|
||||
OLDPTR _ NIL)
|
||||
CHUNK.SYMBOL.TABLE)))
|
||||
(if OLD.CHUNK.FLG
|
||||
then (* increment old-chunk count)
|
||||
(replace (IMCOMPARE.SYMB OLDCOUNT) of SYMB
|
||||
with (ADD1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB)))
|
||||
|
||||
(* smash old-chunk pointer. Note that it must point to the LIST of old-chunks,
|
||||
rather than to the individual one)
|
||||
|
||||
(replace (IMCOMPARE.SYMB OLDPTR) of SYMB with CHUNK.PTR)
|
||||
else (* increment new-chunk count)
|
||||
(replace (IMCOMPARE.SYMB NEWCOUNT) of SYMB
|
||||
with (ADD1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB])
|
||||
)
|
||||
|
||||
(MOVD 'COMPARETEXT 'IMCOMPARE)
|
||||
|
||||
(RPAQQ IMCOMPARE.LAST.NODE NIL)
|
||||
|
||||
(RPAQQ IMCOMPARE.LAST.GRAPH.WINDOW NIL)
|
||||
|
||||
(RPAQQ IMCOMPARE.HASH.TYPE.MENU NIL)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD IMCOMPARE.CHUNK (HASHVALUE FILEPTR CHUNKLENGTH FILENAME . OTHERCHUNK)
|
||||
FILEPTR _ 1 CHUNKLENGTH _ 0)
|
||||
|
||||
(RECORD IMCOMPARE.SYMB (NEWCOUNT OLDCOUNT . OLDPTR))
|
||||
)
|
||||
|
||||
(FILESLOAD GRAPHER)
|
||||
(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1295 39023 (COMPARETEXT 1305 . 3700) (IMCOMPARE.BOXNODE 3702 . 4218) (IMCOMPARE.CHUNKS
|
||||
4220 . 8406) (IMCOMPARE.COLLECT.HASH.CHUNKS 8408 . 9491) (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH 9493
|
||||
. 18359) (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT 18361 . 19124) (IMCOMPARE.HASH 19126 . 26281) (
|
||||
IMCOMPARE.LEFTBUTTONFN 26283 . 28019) (IMCOMPARE.LENGTHEN.ATOM 28021 . 28659) (
|
||||
IMCOMPARE.MERGE.CONNECTED.CHUNKS 28661 . 32157) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 32159 . 34114) (
|
||||
IMCOMPARE.MIDDLEBUTTONFN 34116 . 36688) (IMCOMPARE.SHOW.DIST 36690 . 37136) (
|
||||
IMCOMPARE.UPDATE.SYMBOL.TABLE 37138 . 39021)))))
|
||||
STOP
|
||||
@@ -1,660 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "23-Dec-98 17:05:12" {DSK}<project>medley3.5>lispusers>comparetext.;3 39844
|
||||
|
||||
changes to%: (FNS IMCOMPARE.HASH IMCOMPARE.COLLECT.HASH.CHUNKS)
|
||||
(VARS COMPARETEXTCOMS)
|
||||
|
||||
previous date%: "18-Nov-93 14:43:00" {DSK}<project>medley3.5>lispusers>comparetext.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1984, 1985, 1993, 1998 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COMPARETEXTCOMS)
|
||||
|
||||
(RPAQQ COMPARETEXTCOMS
|
||||
((DECLARE%: EVAL@COMPILE (FILES (LOADCOMP)
|
||||
GRAPHER))
|
||||
(FNS COMPARETEXT IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS
|
||||
IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH IMCOMPARE.FIND.TEDIT.TEXT.OBJECT IMCOMPARE.HASH
|
||||
IMCOMPARE.LEFTBUTTONFN IMCOMPARE.LENGTHEN.ATOM IMCOMPARE.MERGE.CONNECTED.CHUNKS
|
||||
IMCOMPARE.MERGE.UNCONNECTED.CHUNKS IMCOMPARE.MIDDLEBUTTONFN IMCOMPARE.SHOW.DIST
|
||||
IMCOMPARE.UPDATE.SYMBOL.TABLE)
|
||||
(P (MOVD 'COMPARETEXT 'IMCOMPARE))
|
||||
(VARS (IMCOMPARE.LAST.NODE NIL)
|
||||
(IMCOMPARE.LAST.GRAPH.WINDOW NIL)
|
||||
(IMCOMPARE.HASH.TYPE.MENU NIL))
|
||||
(RECORDS IMCOMPARE.CHUNK IMCOMPARE.SYMB)
|
||||
(FILES GRAPHER)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
GRAPHER)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(COMPARETEXT
|
||||
[LAMBDA (NEWFILENAME OLDFILENAME HASH.TYPE GRAPH.REGION)
|
||||
(* mjs " 8-Jan-84 21:06")
|
||||
|
||||
(* Compares the two files, and produces a graph showing their corresponding
|
||||
chunks. The courseness of the "chunking" is determined by HASH.TYPE, which may
|
||||
be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA.
|
||||
The file difference graph is displayed at GRAPHREGION.
|
||||
If GRAPH.REGION = NIL, the user is asked to specify a region.
|
||||
If GRAPH.REGION = T, a standard region is used.)
|
||||
|
||||
(PROG ((NEWFILE (FINDFILE NEWFILENAME T))
|
||||
(OLDFILE (FINDFILE OLDFILENAME T)))
|
||||
(if (AND OLDFILE NEWFILE)
|
||||
then (* compare the two "chunks"
|
||||
consisting of the entire text of the
|
||||
two files)
|
||||
(IMCOMPARE.CHUNKS (create IMCOMPARE.CHUNK
|
||||
FILENAME _ NEWFILE
|
||||
FILEPTR _ 0
|
||||
CHUNKLENGTH _ (GETFILEINFO NEWFILE 'LENGTH))
|
||||
(create IMCOMPARE.CHUNK
|
||||
FILENAME _ OLDFILE
|
||||
FILEPTR _ 0
|
||||
CHUNKLENGTH _ (GETFILEINFO OLDFILE 'LENGTH))
|
||||
HASH.TYPE
|
||||
(if (EQ GRAPH.REGION T)
|
||||
then (create REGION
|
||||
LEFT _ 25
|
||||
BOTTOM _ 25
|
||||
WIDTH _ 500
|
||||
HEIGHT _ 150)
|
||||
elseif GRAPH.REGION
|
||||
else (CLRPROMPT)
|
||||
(printout PROMPTWINDOW
|
||||
"Please specify a window for the file difference graph" T)
|
||||
(GETREGION)))
|
||||
else (printout T "Can't find both files: " NEWFILENAME " & " OLDFILENAME
|
||||
" --- IMCOMPARE aborted" T])
|
||||
|
||||
(IMCOMPARE.BOXNODE
|
||||
[LAMBDA (NODE WINDOW) (* rmk%: "14-Dec-84 13:40")
|
||||
(if IMCOMPARE.LAST.NODE
|
||||
then (RESET/NODE/BORDER IMCOMPARE.LAST.NODE 'INVERT IMCOMPARE.LAST.GRAPH.WINDOW)
|
||||
(SETQ IMCOMPARE.LAST.NODE NIL)
|
||||
(SETQ IMCOMPARE.LAST.GRAPH.WINDOW NIL))
|
||||
(if NODE
|
||||
then (RESET/NODE/BORDER NODE 'INVERT WINDOW)
|
||||
(SETQ IMCOMPARE.LAST.NODE NODE)
|
||||
(SETQ IMCOMPARE.LAST.GRAPH.WINDOW WINDOW])
|
||||
|
||||
(IMCOMPARE.CHUNKS
|
||||
[LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION)
|
||||
(* rmk%: " 8-Sep-84 00:06")
|
||||
|
||||
(* this is the main text-comparison function.
|
||||
It compares the text in the two chunks <which may be small pieces of files, or
|
||||
entire files> and produces a graph showing how the sub-chunks of the two main
|
||||
chunks are related. The two main chunks may be in the same file, and the file
|
||||
may actually be an open Tedit textstream.
|
||||
The main chunks are broken down according to HASH.TYPE, which may be PARA
|
||||
<chunk by paragraph>, LINE, or WORD. HASH.TYPE = NIL defaults to PARA.
|
||||
The file difference graph is displayed at GRAPH.REGION.)
|
||||
|
||||
(* this text comparison algorithm is originally from the article
|
||||
"A Technique for Isolating Differences Between Files" by Paul Heckel, in CACM,
|
||||
V21, %#4, April 1978 --- major difference is that I use lists instead of arrays)
|
||||
|
||||
(PROG ((CHUNK.SYMBOL.TABLE (HASHARRAY 500))
|
||||
NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST)
|
||||
|
||||
(* * collect lists of chunks from each of the main chunks, dividing them
|
||||
according to HASH.TYPE)
|
||||
|
||||
(SETQ NEWFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS NEWFILE.SPEC.CHUNK HASH.TYPE))
|
||||
(SETQ OLDFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS OLDFILE.SPEC.CHUNK HASH.TYPE))
|
||||
|
||||
(* * update the chunk symbol table. For each hash value, this table records the
|
||||
number of "new" chunks with that hash value, the number of "old" chunks with
|
||||
that value, and a pointer to the place in OLD.CHUNK.LIST <not to an OLD chunk
|
||||
itself>.)
|
||||
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE NEWFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE NIL)
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE OLDFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE T)
|
||||
|
||||
(* * For every new chunk whose hash value matches EXACTLY ONE old chunk's
|
||||
value, "connect" it to the old chunk by setting the new chunk's OTHERCHUNK
|
||||
field to point to the appropriate place in the old chunk list <not the old
|
||||
chunk directly>. Also, make sure that OTHERCHUNK of the matching old chunk is
|
||||
non-NIL, so that unconnected old chunks will be merged correctly.)
|
||||
|
||||
(for NEW.CHUNK in NEWFILE.CHUNK.LIST bind SYMB
|
||||
do (SETQ SYMB (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of NEW.CHUNK)
|
||||
CHUNK.SYMBOL.TABLE))
|
||||
(if (AND (EQ 1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB))
|
||||
(EQ 1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB)))
|
||||
then (replace (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK
|
||||
with (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB))
|
||||
(replace (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of (CAR (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB))
|
||||
with T)))
|
||||
|
||||
(* * merge connected chunks forward)
|
||||
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST NIL)
|
||||
|
||||
(* * merge connected chunks backwards)
|
||||
|
||||
(SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
|
||||
(SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST T)
|
||||
(SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
|
||||
(SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
|
||||
|
||||
(* * merge unconnected chunks)
|
||||
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS NEWFILE.CHUNK.LIST)
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS OLDFILE.CHUNK.LIST)
|
||||
|
||||
(* * now, the file comparison is complete.
|
||||
Format and display the file difference graph)
|
||||
|
||||
(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK
|
||||
HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST])
|
||||
|
||||
(IMCOMPARE.COLLECT.HASH.CHUNKS
|
||||
[LAMBDA (CHUNK HASH.TYPE) (* ; "Edited 23-Dec-98 16:54 by rmk:")
|
||||
(* mjs " 8-Jan-84 20:57")
|
||||
|
||||
(* * returns a list of the chunks in CHUNK as hashed of type HASH.TYPE)
|
||||
|
||||
(LET (STREAM END.OF.CHUNK.PTR CHUNK.LIST)
|
||||
[SETQ STREAM (OPENSTREAM (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK)
|
||||
'INPUT
|
||||
'OLD
|
||||
'((TYPE TEXT]
|
||||
(SETFILEPTR STREAM (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK))
|
||||
(SETQ END.OF.CHUNK.PTR (IPLUS (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)))
|
||||
(SETQ CHUNK.LIST (until (IGEQ (GETFILEPTR STREAM)
|
||||
END.OF.CHUNK.PTR) collect (IMCOMPARE.HASH STREAM
|
||||
END.OF.CHUNK.PTR
|
||||
HASH.TYPE)))
|
||||
(CLOSEF STREAM)
|
||||
CHUNK.LIST])
|
||||
|
||||
(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH
|
||||
[LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST
|
||||
OLDFILE.CHUNK.LIST) (* mjs "11-Jul-85 09:10")
|
||||
|
||||
(* * format and display the graph)
|
||||
|
||||
(PROG ((NEWFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of NEWFILE.SPEC.CHUNK))
|
||||
(OLDFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of OLDFILE.SPEC.CHUNK))
|
||||
(OLD.CHUNK.NODE.FROM.NODES NIL)
|
||||
(BORDERSIZE 1)
|
||||
GRAPH.WINDOW NEW.CHUNK.NODES OLD.CHUNK.NODES OLD.CHUNK.XCOORD NEW.CHUNK.XCOORD
|
||||
YCOORD.INCREMENT DIFF.GRAPH)
|
||||
|
||||
(* * set up GRAPH.WINDOW. This is done first so you can get the width and
|
||||
height of strings to be printed in the window.)
|
||||
|
||||
[SETQ GRAPH.WINDOW (CREATEW GRAPH.REGION (CONCAT "Text File Differences, hashed by "
|
||||
(SELECTQ HASH.TYPE
|
||||
((PARA NIL)
|
||||
"Paragraph")
|
||||
(LINE "Line")
|
||||
(WORD "Word")
|
||||
(SHOULDNT]
|
||||
(WINDOWPROP GRAPH.WINDOW 'IMPARE.HASH.TYPE HASH.TYPE)
|
||||
[WINDOWADDPROP GRAPH.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW)
|
||||
(if (EQ WINDOW
|
||||
IMCOMPARE.LAST.GRAPH.WINDOW)
|
||||
then (SETQ
|
||||
IMCOMPARE.LAST.GRAPH.WINDOW
|
||||
NIL)
|
||||
(SETQ IMCOMPARE.LAST.NODE NIL]
|
||||
(SETQ NEW.CHUNK.XCOORD (IQUOTIENT (STRINGWIDTH NEWFILENAME GRAPH.WINDOW)
|
||||
2))
|
||||
[SETQ OLD.CHUNK.XCOORD (IPLUS NEW.CHUNK.XCOORD (IMAX 100 (IPLUS NEW.CHUNK.XCOORD
|
||||
(IQUOTIENT (STRINGWIDTH
|
||||
OLDFILENAME
|
||||
GRAPH.WINDOW)
|
||||
2)
|
||||
20]
|
||||
[SETQ YCOORD.INCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE)
|
||||
(fetch (REGION HEIGHT) of (STRINGREGION
|
||||
NEWFILENAME
|
||||
GRAPH.WINDOW]
|
||||
|
||||
(* * collect new-chunk graph nodes, while accumulating
|
||||
OLD.CHUNK.NODE.FROM.NODES, assoc list from old-chunks to new-chunks)
|
||||
|
||||
(SETQ NEW.CHUNK.NODES (for NEW.CHUNK in NEWFILE.CHUNK.LIST as Y from
|
||||
YCOORD.INCREMENT
|
||||
by YCOORD.INCREMENT bind CORRESPONDING.OLD.CHUNK
|
||||
collect (SETQ CORRESPONDING.OLD.CHUNK
|
||||
(CAR (fetch (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of NEW.CHUNK)))
|
||||
(if CORRESPONDING.OLD.CHUNK
|
||||
then (SETQ OLD.CHUNK.NODE.FROM.NODES
|
||||
(CONS (CONS CORRESPONDING.OLD.CHUNK NEW.CHUNK)
|
||||
OLD.CHUNK.NODE.FROM.NODES)))
|
||||
(* Start out with 2 point white
|
||||
border, so we can invert it)
|
||||
(NODECREATE NEW.CHUNK (IMCOMPARE.LENGTHEN.ATOM
|
||||
(PACK* (fetch (IMCOMPARE.CHUNK
|
||||
FILEPTR)
|
||||
of NEW.CHUNK)
|
||||
":"
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of NEW.CHUNK))
|
||||
12)
|
||||
(create POSITION
|
||||
XCOORD _ NEW.CHUNK.XCOORD
|
||||
YCOORD _ Y)
|
||||
(if CORRESPONDING.OLD.CHUNK
|
||||
then (LIST CORRESPONDING.OLD.CHUNK)
|
||||
else NIL)
|
||||
NIL DEFAULTFONT -2)))
|
||||
(SETQ OLD.CHUNK.NODES (for OLD.CHUNK in OLDFILE.CHUNK.LIST as Y from
|
||||
YCOORD.INCREMENT
|
||||
by YCOORD.INCREMENT bind CORRESPONDING.NEW.CHUNK
|
||||
collect (SETQ CORRESPONDING.NEW.CHUNK (CDR (ASSOC OLD.CHUNK
|
||||
OLD.CHUNK.NODE.FROM.NODES
|
||||
)))
|
||||
(NODECREATE OLD.CHUNK (IMCOMPARE.LENGTHEN.ATOM
|
||||
(PACK* (fetch (IMCOMPARE.CHUNK
|
||||
FILEPTR)
|
||||
of OLD.CHUNK)
|
||||
":"
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of OLD.CHUNK))
|
||||
12 "-")
|
||||
(create POSITION
|
||||
XCOORD _ OLD.CHUNK.XCOORD
|
||||
YCOORD _ Y)
|
||||
NIL
|
||||
(if CORRESPONDING.NEW.CHUNK
|
||||
then (LIST CORRESPONDING.NEW.CHUNK)
|
||||
else NIL)
|
||||
DEFAULTFONT -2)))
|
||||
(SETQ DIFF.GRAPH (create GRAPH
|
||||
DIRECTEDFLG _ T
|
||||
SIDESFLG _ T
|
||||
GRAPHNODES _
|
||||
(NCONC (LIST (NODECREATE NEWFILE.SPEC.CHUNK NEWFILENAME
|
||||
(create POSITION
|
||||
XCOORD _ NEW.CHUNK.XCOORD
|
||||
YCOORD _ 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
NEW.CHUNK.NODES
|
||||
(LIST (NODECREATE OLDFILE.SPEC.CHUNK OLDFILENAME
|
||||
(create POSITION
|
||||
XCOORD _ OLD.CHUNK.XCOORD
|
||||
YCOORD _ 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
OLD.CHUNK.NODES)))
|
||||
(SHOWGRAPH DIFF.GRAPH GRAPH.WINDOW (FUNCTION IMCOMPARE.LEFTBUTTONFN)
|
||||
(FUNCTION IMCOMPARE.MIDDLEBUTTONFN)
|
||||
T NIL])
|
||||
|
||||
(IMCOMPARE.FIND.TEDIT.TEXT.OBJECT
|
||||
[LAMBDA (FILE) (* mjs " 2-Jan-84 16:19")
|
||||
|
||||
(* returns the Tedit text object of the first Tedit window which is currently
|
||||
looking at FILE, if there is one. Returns NIL if none is found.)
|
||||
|
||||
(PROG ((TEDIT.TEXT.OBJECT NIL))
|
||||
(for X in (OPENWINDOWS) bind POSS.TOBJ POSS.FILENAME
|
||||
when (SETQ POSS.TOBJ (WINDOWPROP X 'TEXTOBJ)) repeatuntil TEDIT.TEXT.OBJECT
|
||||
do (SETQ POSS.FILENAME (FULLNAME (fetch (TEXTOBJ TXTFILE) of POSS.TOBJ)))
|
||||
(if (EQ FILE POSS.FILENAME)
|
||||
then (SETQ TEDIT.TEXT.OBJECT POSS.TOBJ)))
|
||||
(RETURN TEDIT.TEXT.OBJECT])
|
||||
|
||||
(IMCOMPARE.HASH
|
||||
[LAMBDA (STREAM EOF.PTR HASH.TYPE) (* ; "Edited 23-Dec-98 16:58 by rmk:")
|
||||
|
||||
(* reads caracters from STREAM and creates a hash value for the "next" "chunk"
|
||||
A chunk is a paragraph ending in two consecutive CRs <HASH.TYPE = NIL or PARA>,
|
||||
a line ending in a CR <HASH.TYPE = LINE>, or a word ending in any white space
|
||||
character space <HASH.TYPE = WORD>. In computing the hash value, white space is
|
||||
ignored. IMCOMPARE.HASH automatically stops before reading char number EOF.PTR
|
||||
Returns an IMCOMPARE.CHUNK containing the hash value, the file pointer of the
|
||||
beginning of the chunk, the length of the chunk, and the fullname of the stream)
|
||||
|
||||
(* Note%: Most of the time in COMPARETEXT is spent reading in and hashing
|
||||
chunks, so this function was optimizes for speed, at the expense of length)
|
||||
|
||||
(PROG ((BEGIN.FILE.PTR (GETFILEPTR STREAM))
|
||||
(EOLC (GETFILEINFO STREAM 'EOL))
|
||||
(HASHNUM 0)
|
||||
FILE.PTR C)
|
||||
(SETQ FILE.PTR BEGIN.FILE.PTR)
|
||||
(SELECTQ HASH.TYPE
|
||||
((NIL PARA)
|
||||
|
||||
(* Paragraph chunks end with two consecutive EOL's.
|
||||
In order to detect this without slowing down the gobbling of normal chars,
|
||||
LAST.EOL.POS is set to the filepos of the last EOL detected.
|
||||
This is only checked when another EOL comes along.)
|
||||
|
||||
(PROG ((LAST.EOL.POS -5))
|
||||
loop
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (SETQ C (BIN STREAM))
|
||||
(CR
|
||||
|
||||
(* If this is the second consecutive CR, this is the end of the chunk.
|
||||
Otherwise, reset LAST.EOL.POS)
|
||||
|
||||
(SELECTQ EOLC
|
||||
(CR (if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM)))
|
||||
then (GO endchunk)
|
||||
else (SETQ LAST.EOL.POS (GETFILEPTR STREAM))))
|
||||
(CRLF (if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SELCHARQ (\PEEKBIN STREAM T)
|
||||
(LF (SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(BIN STREAM)
|
||||
(if (IEQP LAST.EOL.POS (IDIFFERENCE
|
||||
(GETFILEPTR STREAM)
|
||||
2))
|
||||
then (GO endchunk)
|
||||
else (SETQ LAST.EOL.POS (GETFILEPTR STREAM
|
||||
))))
|
||||
NIL))
|
||||
NIL))
|
||||
(LF [COND
|
||||
((EQ EOLC 'LF)
|
||||
(if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM)))
|
||||
then (GO endchunk)
|
||||
else (SETQ LAST.EOL.POS (GETFILEPTR STREAM])
|
||||
((SPACE TAB))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16)))
|
||||
(GO loop)))
|
||||
(LINE (* Line chunks end on a single CR.)
|
||||
(PROG NIL
|
||||
loop
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (SETQ C (BIN STREAM))
|
||||
(CR (SELECTQ EOLC
|
||||
(CR (GO endchunk))
|
||||
(LF)
|
||||
(CRLF (if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SELCHARQ (\PEEKBIN STREAM T)
|
||||
(LF (SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(BIN STREAM)
|
||||
(GO endchunk))
|
||||
NIL))
|
||||
(SHOULDNT)))
|
||||
(LF (AND (EQ EOLC 'LF)
|
||||
(GO endchunk)))
|
||||
((SPACE TAB))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16)))
|
||||
(GO loop)))
|
||||
(WORD (* word chunks end on any white
|
||||
space)
|
||||
(PROG NIL
|
||||
loop
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (SETQ C (BIN STREAM))
|
||||
((CR SPACE TAB LF)
|
||||
(GO endchunk))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16)))
|
||||
(GO loop)))
|
||||
(HELP (CONCAT "Unrecognize HASHTYPE " HASH.TYPE)
|
||||
"
|
||||
Should be PARA, LINE, or WORD"))
|
||||
endchunk
|
||||
(* flush all white space before next
|
||||
chunk)
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (BIN STREAM)
|
||||
((CR SPACE TAB LF)
|
||||
(GO endchunk))
|
||||
(PROGN (SETQ FILE.PTR (SUB1 FILE.PTR))
|
||||
(SETFILEPTR STREAM FILE.PTR)))
|
||||
return
|
||||
(RETURN (create IMCOMPARE.CHUNK
|
||||
HASHVALUE _ HASHNUM
|
||||
FILEPTR _ BEGIN.FILE.PTR
|
||||
CHUNKLENGTH _ (IDIFFERENCE FILE.PTR BEGIN.FILE.PTR)
|
||||
FILENAME _ (FULLNAME STREAM])
|
||||
|
||||
(IMCOMPARE.LEFTBUTTONFN
|
||||
[LAMBDA (GNODE WINDOW) (* mjs " 2-Apr-85 14:21")
|
||||
(if GNODE
|
||||
then (IMCOMPARE.BOXNODE GNODE WINDOW)
|
||||
(PROG ((NODEID (fetch (GRAPHNODE NODEID) of GNODE))
|
||||
(FILEPTR 1)
|
||||
(CHUNKLENGTH 0)
|
||||
(TEDIT.TEXT.OBJECT NIL)
|
||||
FILE)
|
||||
(SETQ FILE (fetch (IMCOMPARE.CHUNK FILENAME) of NODEID))
|
||||
(SETQ FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of NODEID))
|
||||
(SETQ CHUNKLENGTH (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NODEID))
|
||||
(SETQ TEDIT.TEXT.OBJECT (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT FILE))
|
||||
(if TEDIT.TEXT.OBJECT
|
||||
then (TEDIT.SETSEL TEDIT.TEXT.OBJECT (IMAX 1 (IDIFFERENCE FILEPTR 25))
|
||||
0
|
||||
'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
|
||||
(TEDIT.SETSEL TEDIT.TEXT.OBJECT FILEPTR CHUNKLENGTH 'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
|
||||
(TTY.PROCESS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of
|
||||
|
||||
TEDIT.TEXT.OBJECT
|
||||
))
|
||||
'PROCESS))
|
||||
else (TEDIT FILE NIL NIL (LIST 'SEL (LIST FILEPTR CHUNKLENGTH])
|
||||
|
||||
(IMCOMPARE.LENGTHEN.ATOM
|
||||
[LAMBDA (X MIN.LENGTH EXTENDER) (* mjs "30-Dec-83 15:11")
|
||||
|
||||
(* makes sure that the atom X is at least MIN.LENGTH characters long, by
|
||||
concatinating the first character of EXTENDER
|
||||
(or space, if not given) to the front)
|
||||
|
||||
(PROG ((C (CHCON X)))
|
||||
(SETQ EXTENDER (if EXTENDER
|
||||
then (CHCON1 EXTENDER)
|
||||
else (CHARCODE SPACE)))
|
||||
(while (ILESSP (LENGTH C)
|
||||
MIN.LENGTH) do (SETQ C (CONS EXTENDER C)))
|
||||
(RETURN (PACKC C])
|
||||
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS
|
||||
[LAMBDA (NEW.CHUNK.LIST BACKWARDS.FLG) (* mjs " 6-Jan-84 10:35")
|
||||
(while NEW.CHUNK.LIST bind NEW.CHUNK OLD.CHUNK.PTR
|
||||
do (SETQ NEW.CHUNK (CAR NEW.CHUNK.LIST))
|
||||
(SETQ OLD.CHUNK.PTR (fetch (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK))
|
||||
(if [OR (NULL (CDR NEW.CHUNK.LIST))
|
||||
(NULL OLD.CHUNK.PTR)
|
||||
(NULL (CDR OLD.CHUNK.PTR))
|
||||
(NOT (EQP (fetch (IMCOMPARE.CHUNK HASHVALUE) of (CADR NEW.CHUNK.LIST
|
||||
))
|
||||
(fetch (IMCOMPARE.CHUNK HASHVALUE) of (CADR OLD.CHUNK.PTR]
|
||||
then (SETQ NEW.CHUNK.LIST (CDR NEW.CHUNK.LIST))
|
||||
else
|
||||
|
||||
(* next chunks have same hash, so "murge" them into current chunks by adding
|
||||
their chunk lengths to the current chunks, and splicing out the next chunks)
|
||||
|
||||
[replace (IMCOMPARE.CHUNK CHUNKLENGTH) of NEW.CHUNK
|
||||
with (IPLUS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NEW.CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CADR
|
||||
NEW.CHUNK.LIST
|
||||
]
|
||||
[replace (IMCOMPARE.CHUNK CHUNKLENGTH) of (CAR OLD.CHUNK.PTR)
|
||||
with (IPLUS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CAR
|
||||
OLD.CHUNK.PTR
|
||||
))
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CADR
|
||||
OLD.CHUNK.PTR
|
||||
]
|
||||
[if BACKWARDS.FLG
|
||||
then (* if the list is backwards, copy
|
||||
next fileptr)
|
||||
(replace (IMCOMPARE.CHUNK FILEPTR) of NEW.CHUNK
|
||||
with (fetch (IMCOMPARE.CHUNK FILEPTR) of (CADR
|
||||
NEW.CHUNK.LIST
|
||||
)))
|
||||
(replace (IMCOMPARE.CHUNK FILEPTR) of (CAR OLD.CHUNK.PTR)
|
||||
with (fetch (IMCOMPARE.CHUNK FILEPTR) of (CADR
|
||||
OLD.CHUNK.PTR
|
||||
]
|
||||
(* splice chunks out of new and old
|
||||
list)
|
||||
(RPLACD NEW.CHUNK.LIST (CDDR NEW.CHUNK.LIST))
|
||||
(RPLACD OLD.CHUNK.PTR (CDDR OLD.CHUNK.PTR])
|
||||
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS
|
||||
[LAMBDA (CHUNK.LST) (* mjs " 5-JAN-84 13:58")
|
||||
(while CHUNK.LST bind CHUNK do (SETQ CHUNK (CAR CHUNK.LST))
|
||||
(if (OR (NULL (CDR CHUNK.LST))
|
||||
(fetch (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of (CADR CHUNK.LST)))
|
||||
then (SETQ CHUNK.LST (CDR CHUNK.LST))
|
||||
else (* both current chunk and next chunk
|
||||
have no OTHERCHUNK, so merge them)
|
||||
[replace (IMCOMPARE.CHUNK CHUNKLENGTH)
|
||||
of CHUNK
|
||||
with (IPLUS (fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of (CADR CHUNK.LST]
|
||||
(* splice chunks out of new and old
|
||||
list)
|
||||
(RPLACD CHUNK.LST (CDDR CHUNK.LST])
|
||||
|
||||
(IMCOMPARE.MIDDLEBUTTONFN
|
||||
[LAMBDA (GNODE WINDOW) (* mjs " 6-Jan-84 11:37")
|
||||
|
||||
(* This function is called if the MIDDLE mouse button is pressed over a graph
|
||||
node. The selected node is IMCOMPARE-ed with the last node selected <which is
|
||||
boxed>. The type of hashing used <PARA, LINE, or WORD> is selected from a
|
||||
pop-up menu. If none of the hashing types is selected, the current node is
|
||||
boxed. The pop-up menu is always located a little above the current cursor
|
||||
position, so a quick double-MIDDLE-click is an easy way to change the current
|
||||
boxed node.)
|
||||
|
||||
(if GNODE
|
||||
then (PROG (INNER.HASH.TYPE)
|
||||
(CLRPROMPT)
|
||||
(printout PROMPTWINDOW "Please select the type of hashing you wish." T)
|
||||
[SETQ INNER.HASH.TYPE
|
||||
(MENU (if (type? MENU IMCOMPARE.HASH.TYPE.MENU)
|
||||
then IMCOMPARE.HASH.TYPE.MENU
|
||||
else (SETQ IMCOMPARE.HASH.TYPE.MENU
|
||||
(create MENU
|
||||
ITEMS _ '(PARA LINE WORD)
|
||||
MENUOFFSET _
|
||||
(create POSITION
|
||||
XCOORD _ 20
|
||||
YCOORD _ -20]
|
||||
(if (NULL INNER.HASH.TYPE)
|
||||
then (* if no hash type is selected, just
|
||||
box the current node and return)
|
||||
(IMCOMPARE.BOXNODE GNODE WINDOW)
|
||||
(RETURN))
|
||||
(if (NULL IMCOMPARE.LAST.NODE)
|
||||
then (CLRPROMPT)
|
||||
(PRIN1 "You must select another graph node first." PROMPTWINDOW)
|
||||
(RETURN))
|
||||
(printout PROMPTWINDOW "Comparing chunks by " INNER.HASH.TYPE T)
|
||||
(IMCOMPARE.CHUNKS (fetch (GRAPHNODE NODEID) of IMCOMPARE.LAST.NODE
|
||||
)
|
||||
(fetch (GRAPHNODE NODEID) of GNODE)
|
||||
INNER.HASH.TYPE
|
||||
(WINDOWPROP WINDOW 'REGION])
|
||||
|
||||
(IMCOMPARE.SHOW.DIST
|
||||
[LAMBDA (LST MAX) (* mjs "30-Dec-83 15:13")
|
||||
(PROG ((WINDOW (CREATEW))
|
||||
MAX.Y X MAX.X)
|
||||
(SETQ MAX.X (WINDOWPROP WINDOW 'WIDTH))
|
||||
(SETQ MAX.Y (WINDOWPROP WINDOW 'HEIGHT))
|
||||
(for SAMPLE in LST do (SETQ X (FTIMES MAX.X (FQUOTIENT SAMPLE MAX)))
|
||||
(DRAWLINE X 0 X MAX.Y 1 'PAINT WINDOW])
|
||||
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE
|
||||
[LAMBDA (CHUNK.LIST CHUNK.SYMBOL.TABLE OLD.CHUNK.FLG) (* mjs " 8-Jan-84 21:01")
|
||||
|
||||
(* * update the chunk symbol table. For each hash value, this table records the
|
||||
number of "new" chunks with that hash value, the number of "old" chunks with
|
||||
that value, and a pointer to the place in OLD.CHUNK.LIST <not to an OLD chunk
|
||||
itself>.)
|
||||
|
||||
(for CHUNK.PTR on CHUNK.LIST bind CHUNK SYMB
|
||||
do (SETQ CHUNK (CAR CHUNK.PTR))
|
||||
(SETQ SYMB (if (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of CHUNK)
|
||||
CHUNK.SYMBOL.TABLE)
|
||||
else (PUTHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of CHUNK)
|
||||
(create IMCOMPARE.SYMB
|
||||
NEWCOUNT _ 0
|
||||
OLDCOUNT _ 0
|
||||
OLDPTR _ NIL)
|
||||
CHUNK.SYMBOL.TABLE)))
|
||||
(if OLD.CHUNK.FLG
|
||||
then (* increment old-chunk count)
|
||||
(replace (IMCOMPARE.SYMB OLDCOUNT) of SYMB
|
||||
with (ADD1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB)))
|
||||
|
||||
(* smash old-chunk pointer. Note that it must point to the LIST of old-chunks,
|
||||
rather than to the individual one)
|
||||
|
||||
(replace (IMCOMPARE.SYMB OLDPTR) of SYMB with CHUNK.PTR)
|
||||
else (* increment new-chunk count)
|
||||
(replace (IMCOMPARE.SYMB NEWCOUNT) of SYMB
|
||||
with (ADD1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB])
|
||||
)
|
||||
|
||||
(MOVD 'COMPARETEXT 'IMCOMPARE)
|
||||
|
||||
(RPAQQ IMCOMPARE.LAST.NODE NIL)
|
||||
|
||||
(RPAQQ IMCOMPARE.LAST.GRAPH.WINDOW NIL)
|
||||
|
||||
(RPAQQ IMCOMPARE.HASH.TYPE.MENU NIL)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD IMCOMPARE.CHUNK (HASHVALUE FILEPTR CHUNKLENGTH FILENAME . OTHERCHUNK)
|
||||
FILEPTR _ 1 CHUNKLENGTH _ 0)
|
||||
|
||||
(RECORD IMCOMPARE.SYMB (NEWCOUNT OLDCOUNT . OLDPTR))
|
||||
)
|
||||
|
||||
(FILESLOAD GRAPHER)
|
||||
(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993 1998))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1365 39345 (COMPARETEXT 1375 . 3770) (IMCOMPARE.BOXNODE 3772 . 4288) (IMCOMPARE.CHUNKS
|
||||
4290 . 8476) (IMCOMPARE.COLLECT.HASH.CHUNKS 8478 . 9707) (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH 9709
|
||||
. 18575) (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT 18577 . 19340) (IMCOMPARE.HASH 19342 . 26603) (
|
||||
IMCOMPARE.LEFTBUTTONFN 26605 . 28341) (IMCOMPARE.LENGTHEN.ATOM 28343 . 28981) (
|
||||
IMCOMPARE.MERGE.CONNECTED.CHUNKS 28983 . 32479) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 32481 . 34436) (
|
||||
IMCOMPARE.MIDDLEBUTTONFN 34438 . 37010) (IMCOMPARE.SHOW.DIST 37012 . 37458) (
|
||||
IMCOMPARE.UPDATE.SYMBOL.TABLE 37460 . 39343)))))
|
||||
STOP
|
||||
Reference in New Issue
Block a user