-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathBITSNAP
More file actions
136 lines (110 loc) · 6.79 KB
/
Copy pathBITSNAP
File metadata and controls
136 lines (110 loc) · 6.79 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Mar-2025 14:22:15" {DSK}<home>paolo>il>bitsnap>BITSNAP.;8 6857
:EDIT-BY "PA"
:CHANGES-TO (FNS PROMPTFORW)
:PREVIOUS-DATE " 2-Mar-2025 13:16:14" {DSK}<home>paolo>il>bitsnap>BITSNAP.;7)
(PRETTYCOMPRINT BITSNAPCOMS)
(RPAQQ BITSNAPCOMS
((* A screenshot capture tool for Medley Interlisp. It can capture screenshots of the the full
screen, a window or its interior, or an arbitrary area.)
(FNS BMTOPBM PROMPTFORW SNAP)
[DECLARE%: DONTEVAL@LOAD DOCOPY
(ADDVARS (BackgroundMenuCommands
("Screenshot" '(SNAP NIL T)
"Captures and saves the full screen."
(SUBITEMS ("Screen" '(SNAP NIL T)
"Captures and saves the full screen.")
("Window" '(SNAP 'WINDOW T)
"Captures and saves a window with title bar and border."
(SUBITEMS ("Full" '(SNAP 'WINDOW T)
"Captures and saves a window with title bar and border."
)
("Interior" '(SNAP 'INTERIOR T)
"Captures and saves a window without title bar and border."
)))
("Selected" '(SNAP 'SELECTION T)
"Captures and saves an arbitrary screen area."]
(P (SETQ BackgroundMenu))
(FILES BITMAPFNS)))
(* A screenshot capture tool for Medley Interlisp. It can capture screenshots of the the full screen,
a window or its interior, or an arbitrary area.)
(DEFINEQ
(BMTOPBM
[LAMBDA (BITMAP FILE) (* ; "Edited 28-Feb-2025 18:12 by PA")
(* Save BITMAP to FILE in PBM format
and return BITMAP.)
(LET [(WIDTH (BITMAPWIDTH BITMAP))
(HEIGHT (BITMAPHEIGHT BITMAP))
(STREAM (OPENSTREAM FILE 'OUTPUT]
(RESETLST
(RESETSAVE NIL (LIST 'CLOSEF STREAM))
(PRINTOUT STREAM "P1" T)
(PRINTOUT STREAM WIDTH %, HEIGHT T T) (* Lines of PBM files should have no
more than 70 characters.)
(for Y from (SUB1 HEIGHT) to 0 by -1
do (bind (N _ 0) for X from 0 to (SUB1 WIDTH)
do (if (EQP N 70)
then (TERPRI STREAM)
(SETQ N 0))
(PRINTOUT STREAM (BITMAPBIT BITMAP X Y))
(SETQ N (ADD1 N)))
(TERPRI STREAM)))
BITMAP])
(PROMPTFORW
[LAMBDA NIL (* ; "Edited 2-Mar-2025 14:20 by PA")
(* ; "Edited 28-Feb-2025 18:36 by PA")
(* Prompt the user to indicate a window. Displays in the prompt window a message
that advises to place the pointer over a window, waits for the user to click a
mouse button, and returns the window the pointer is over.)
(FRESHLINE PROMPTWINDOW)
(MOUSECONFIRM "Place the pointer over the desired window." "Click any button to proceed."
PROMPTWINDOW T)
(WHICHW])
(SNAP
[LAMBDA (WHAT WHERE) (* ; "Edited 2-Mar-2025 13:14 by PA")
(* Capture the area of the screen indicated by WHAT, save it to the destination
indicated by WHERE, and return a bitmap of the area.
WHAT can be NIL for the full screen, WINDOW for a window including the title bar
and border, INTERIOR for a window with no title or border, or SELECTION for an
arbitrary area. WHERE can be NIL to not save, T to prompt the user for a file
name, or a file name.)
(LET [(BITMAP (SELECTQ WHAT
(WINDOW (WINDOW.BITMAP (PROMPTFORW)))
(INTERIOR (BITMAPCOPY (PROMPTFORW)))
(SELECTION (SNAPW))
(BITMAPCOPY (SCREENBITMAP]
[AND WHERE (BMTOPBM BITMAP (if (EQ WHERE T)
then (FRESHLINE PROMPTWINDOW)
(OR (PROMPTFORWORD "File name:" "screenshot.pbm" NIL
PROMPTWINDOW)
"screenshot.pbm")
else (MKSTRING WHERE] (* SNAPW already displays the captured
area, so no need to do it again.)
(if (NOT (EQ WHAT 'SELECTION))
then (WINDOWBM (if (NULL WHAT)
then (SHRINKBITMAP BITMAP 2 2)
else BITMAP)))
BITMAP])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(ADDTOVAR BackgroundMenuCommands
("Screenshot" '(SNAP NIL T)
"Captures and saves the full screen."
(SUBITEMS ("Screen" '(SNAP NIL T)
"Captures and saves the full screen.")
("Window" '(SNAP 'WINDOW T)
"Captures and saves a window with title bar and border."
(SUBITEMS ("Full" '(SNAP 'WINDOW T)
"Captures and saves a window with title bar and border."
)
("Interior" '(SNAP 'INTERIOR T)
"Captures and saves a window without title bar and border."
)))
("Selected" '(SNAP 'SELECTION T)
"Captures and saves an arbitrary screen area."))))
)
(SETQ BackgroundMenu)
(FILESLOAD BITMAPFNS)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2161 5684 (BMTOPBM 2171 . 3366) (PROMPTFORW 3368 . 4026) (SNAP 4028 . 5682)))))
STOP