![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to bpage.cmd CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [MW Coherent from dump] / coherent / f / usr / lib|
Return to bpage.cmd CVS log | Up to [MW Coherent from dump] / coherent / f / usr / lib |
1.1 root 1: ; BPAGE.CMD: Box Macro and rectangualr region page
2: ; for MicroEMACS 3.9d and above
3: ; (C)opyright 1987 by Suresh Konda and Daniel M Lawrence
4: ; Last Update: 11/02/87
5:
6: ; make sure the function key window is up
7: set %rcfkeys FALSE
8: execute-macro-1
9: write-message "Loading..."
10:
11: ; set the clean procedure up
12: store-procedure clean
13: delete-buffer "[Macro 10]"
14: delete-buffer "[Macro 11]"
15: delete-buffer "[Macro 12]"
16: delete-buffer "[getblock]"
17: delete-buffer "[putblock]"
18: delete-buffer "[Macro 13]"
19: delete-buffer "[Macro 14]"
20: delete-buffer "[Macro 15]"
21: delete-buffer "[Macro 16]"
22: delete-buffer "[Macro 17]"
23: delete-buffer "[Macro 18]"
24: delete-buffer "[Macro 19]"
25: delete-buffer "[drawbox]"
26: delete-buffer "[setpoints]"
27: delete-buffer "[horizontal]"
28: delete-buffer "[vertical]"
29: delete-buffer "[horline]"
30: delete-buffer "[vertline]"
31: delete-buffer "[delcol]"
32: delete-buffer "[iline]"
33: !endm
34:
35: ; Write out the page instructions
36: save-window
37: 1 next-window
38: beginning-of-file
39: set $curcol 25
40: overwrite-string " F1 Line type [DOUBLE] F2 kill block "
41: next-line
42: set $curcol 25
43: overwrite-string " F3 draw box F4 copy block "
44: next-line
45: set $curcol 25
46: overwrite-string " F5 insert line F6 yank block "
47: next-line
48: set $curcol 18
49: overwrite-string "BOX "
50: set $curcol 25
51: overwrite-string " F7 insert space F8 insert block "
52: next-line
53: set $curcol 25
54: overwrite-string " "
55: unmark-buffer
56: beginning-of-file
57: !force restore-window
58: update-screen
59:
60: ; this sets overwrite mode to off. to change it, set rcinsert to 1
61: set %rcinsert 0
62:
63: ; change line type
64:
65: 10 store-macro
66: !if &equ %rcltype 1
67: set %rcltype 2
68: set %rctmp "DOUBLE"
69: !else
70: !if &equ %rcltype 2
71: set %rcltype 3
72: set %rctmp "C-CMNT"
73: !else
74: set %rcltype 1
75: set %rctmp "SINGLE"
76: !endif
77: !endif
78: set %cbuf $cbufname
79: set %cline $cwline
80: select-buffer "Function Keys"
81: beginning-of-file
82: 1 goto-line
83: 40 forward-character
84: 6 delete-next-character
85: insert-string %rctmp
86: unmark-buffer
87: select-buffer %cbuf
88: %cline redraw-display
89: !return
90: !endm
91:
92: ; Draw a box
93:
94: 12 store-macro
95: !if &equal %rcltype 1
96: set %c1 "�"
97: set %c2 "�"
98: set %c3 "�"
99: set %c4 "�"
100: set %c5 "�"
101: set %c6 "�"
102: !else
103: !if &equal %rcltype 2
104: set %c1 "�"
105: set %c2 "�"
106: set %c3 "�"
107: set %c4 "�"
108: set %c5 "�"
109: set %c6 "�"
110: !else
111: set %c1 "/"
112: set %c2 "*"
113: set %c3 "\"
114: set %c4 "\"
115: set %c5 "/"
116: set %c6 "*"
117: !endif
118: !endif
119: run drawbox
120: !endm
121:
122: ; insert a line in a box
123:
124: 14 store-macro
125: run iline
126: !endm
127:
128: ; insert a blank line in a box
129:
130: 16 store-macro
131: set %rctmp %rcltype
132: set %rcltype 0
133: run iline
134: set %rcltype %rctmp
135: !endm
136:
137: store-procedure iline
138: run setpoints
139: !if &equal %pcol %mcol
140: run vertical
141: !else
142: !if &equal %pline %mline
143: run horizontal
144: !else
145: write-message "Illegal point and mark for lines"
146: !endif
147: !endif
148: !endm
149:
150: store-procedure setpoints
151: ; procedure will set pcol, pline, mcol and mline. currently at point
152: ; it will also detab the region
153: set %pcol $curcol
154: set %pline $curline
155: exchange-point-and-mark
156: set %mcol $curcol
157: set %mline $curline
158: exchange-point-and-mark
159: detab-region
160: set $curline %pline
161: set $curcol %pcol
162: !endm
163:
164: store-procedure drawbox
165: run setpoints
166: set $curline %mline
167: set $curcol %mcol
168: ;draw top horizontal line
169: insert-string %c1
170: ; set %width &sub &sub %pcol %mcol 1
171: set %width &add 2 &sub %pcol %mcol
172: %width insert-string %c2
173: insert-string %c3
174: newline-and-indent
175: ;draw bottom horizontal line
176: %pline goto-line
177: next-line
178: end-of-line
179: newline
180: %mcol insert-string " "
181: ; set $curcol %mcol
182: insert-string %c4
183: %width insert-string %c2
184: insert-string %c5
185: ; bump pline
186: set %pline &add %pline 1
187: ;draw verticals -- go to top and work our way down
188: %mline goto-line
189: !while &less $curline %pline
190: next-line
191: end-of-line
192: !if &less $curcol %pcol
193: &sub %pcol $curcol insert-string " "
194: !endif
195: set $curcol %pcol
196: insert-string " "
197: insert-string %c6
198: set $curcol %mcol
199: insert-string %c6
200: insert-string " "
201: !endwhile
202: ;return to point
203: %pline goto-line
204: next-line
205: beginning-of-line
206: %width forward-character
207: 6 forward-character
208: !endm
209:
210: ; user procedure to draw a horizontal from mark to point making spaces for
211: ; the characters.
212: store-procedure horizontal
213: set %s1 "�"
214: set %s2 "�"
215: set %s3 "*"
216: !if &equal %rcltype 0
217: ; then insert blanks
218: set %c1 "�"
219: set %c2 "�"
220: set %c3 " "
221: set %c4 "�"
222: set %c5 "�"
223: set %c6 "�"
224: set %c7 "�"
225: set %c8 "*"
226: !else
227: !if &equal %rcltype 1
228: ; then insert a single line
229: set %c1 "�"
230: set %c2 "�"
231: set %c3 "�"
232: set %c4 "�"
233: set %c5 "�"
234: set %c6 "�"
235: set %c7 "�"
236: set %c8 "*"
237: !else
238: !if &equal %rcltype 2
239: ; then insert a double line
240: set %c1 "�"
241: set %c2 "�"
242: set %c3 "�"
243: set %c4 "�"
244: set %c5 "�"
245: set %c6 "�"
246: set %c7 "�"
247: set %c8 "*"
248: !else
249: set %c1 "*"
250: set %c2 "*"
251: set %c3 "*"
252: set %c4 "*"
253: set %c5 "*"
254: set %c6 "*"
255: set %c7 "*"
256: set %c8 "*"
257: !endif
258: !endif
259: !endif
260: run horline
261: !endm
262:
263: store-procedure vertical
264: set %s1 "�"
265: set %s2 "�"
266: set %s3 "*"
267: !if &equal %rcltype 0
268: set %c1 "�"
269: set %c2 "�"
270: set %c3 " "
271: set %c4 "�"
272: set %c5 "�"
273: set %c6 "�"
274: set %c7 "�"
275: set %c8 "*"
276: !else
277: !if &equal %rcltype 1
278: set %c1 "�"
279: set %c2 "�"
280: set %c3 "�"
281: set %c4 "�"
282: set %c5 "�"
283: set %c6 "�"
284: set %c7 "�"
285: set %c8 "*"
286: !else
287: !if &equal %rcltype 2
288: set %c1 "�"
289: set %c2 "�"
290: set %c3 "�"
291: set %c4 "�"
292: set %c5 "�"
293: set %c6 "�"
294: set %c7 "�"
295: set %c8 "*"
296: !else
297: set %c1 "*"
298: set %c2 "*"
299: set %c3 "*"
300: set %c4 "*"
301: set %c5 "*"
302: set %c6 "*"
303: set %c7 "*"
304: set %c8 "*"
305: !endif
306: !endif
307: !endif
308: run verline
309: !endm
310:
311: store-procedure horline
312: ; procedure to draw a line from beginning of line to point
313: !if &equal %mcol %pcol
314: !return
315: !endif
316: set $curline %pline
317: set $curcol %pcol
318: !if &less %pcol %mcol
319: ; then point was to left of mark. exchange and reset variables
320: exchange-point-and-mark
321: run setpoints
322: !endif
323: !if %rcinsert
324: set $curcol %mcol
325: !else
326: beginning-of-line
327: newline
328: previous-line
329: ; end-of-line
330: ; newline
331: ; move to under mark
332: %mcol insert-string " "
333: !endif
334: ; see if first char is a vertical line
335: previous-line
336: set %char &chr $curchar
337: next-line
338: %rcinsert delete-next-character
339: !if &sequal %char %s1
340: insert-string %c1
341: !else
342: !if &sequal %char %s2
343: insert-string %c2
344: !else
345: !if &sequal %char %s3
346: insert-string %c8
347: !else
348: insert-string %c3
349: !endif
350: !endif
351: !endif
352: ; now for all chars but the last character i.e., char at point
353: !while &less $curcol %pcol
354: previous-line
355: set %char &chr $curchar
356: next-line
357: %rcinsert delete-next-character
358: !if &sequal %char %s1
359: insert-string %c4
360: !else
361: !if &sequal %char %s2
362: insert-string %c5
363: !else
364: !if &sequal %char %s3
365: insert-string %c8
366: !else
367: insert-string %c3
368: !endif
369: !endif
370: !endif
371: !endwhile
372: ; see if last char is a vertical line
373: previous-line
374: set %char &chr $curchar
375: next-line
376: %rcinsert delete-next-character
377: !if &sequal %char %s1
378: insert-string %c6
379: !else
380: !if &sequal %char %s2
381: insert-string %c7
382: !else
383: !if &sequal %char %s3
384: insert-string %c8
385: !else
386: insert-string %c3
387: !endif
388: !endif
389: !endif
390: !endm
391:
392: store-procedure verline
393: ; proc to draw vertical line from mark to point. mark should be above point.
394: !if &equal %mline %pline
395: !return
396: !endif
397: ; if point was above mark exchange and reset variables
398: !if &less %pline %mline
399: exchange-point-and-mark
400: run setpoints
401: !endif
402: ;top line
403: %mline goto-line
404: set $curcol %pcol
405: backward-character
406: set %char &chr $curchar
407: forward-character
408: %rcinsert delete-next-character
409: !if &sequal %char %s1
410: insert-string %c1
411: !else
412: !if &sequal %char %s2
413: insert-string %c2
414: !else
415: !if &sequal %char %s3
416: insert-string %c8
417: !else
418: insert-string %c3
419: !endif
420: !endif
421: !endif
422: ;all but pline
423: !while &less $curline &sub %pline 1
424: next-line
425: beginning-of-line
426: set $curcol %pcol
427: backward-character
428: set %char &chr $curchar
429: forward-character
430: %rcinsert delete-next-character
431: !if &sequal %char %s1
432: insert-string %c4
433: !else
434: !if &sequal %char %s2
435: insert-string %c5
436: !else
437: !if &sequal %char %s3
438: insert-string %c8
439: !else
440: insert-string %c3
441: !endif
442: !endif
443: !endif
444: !endwhile
445: ; bottom line
446: next-line
447: beginning-of-line
448: set $curcol %pcol
449: backward-character
450: set %char &chr $curchar
451: forward-character
452: %rcinsert delete-next-character
453: !if &sequal %char %s1
454: insert-string %c6
455: !else
456: !if &sequal %char %s2
457: insert-string %c7
458: !else
459: !if &sequal %char %s3
460: insert-string %c8
461: !else
462: insert-string %c3
463: !endif
464: !endif
465: !endif
466: !endm
467:
468: store-procedure delcol
469: ; proc to delete column. we will use the getblock procedure with the column of
470: ; the point set to one beyond the column point
471: set-points
472: !if &equal %mcol %pcol
473: ; same columns
474: forward-character
475: run getblock
476: !return
477: !else
478: !if &equal %mline %pline
479: run getblock
480: !return
481: !endif
482: !endm
483:
484: ; delete a rectangular block of text
485:
486: 11 store-macro
487: set %bkcopy FALSE
488: run getblock
489: write-message "[Block deleted]"
490: !endm
491:
492: ; copy a rectangular region
493:
494: 13 store-macro
495: set %bkcopy TRUE
496: run getblock
497: write-message "[Block copied]"
498: !endm
499:
500: ; yank a rectangular region
501:
502: 15 store-macro
503: set %bkcopy TRUE
504: run putblock
505: !endm
506:
507: ; insert a rectangular region
508:
509: 17 store-macro
510: set %bkcopy FALSE
511: run putblock
512: !endm
513:
514: store-procedure getblock
515: ;set up needed variables
516: set $discmd FALSE
517: delete-buffer "[block]"
518: set %rcbuf $cbufname
519: set %cline $cwline
520:
521: ;save block boundries
522: set %endpos $curcol
523: set %endline $curline
524: detab-region
525: exchange-point-and-mark
526: set %begpos $curcol
527: set %begline $curline
528: set %blwidth &sub %endpos %begpos
529:
530: ;scan through the block
531: set $curline %begline
532: !while &less $curline &add %endline 1
533: ;grab the part of this line needed
534: !force set $curcol %begpos
535: set-mark
536: !force set $curcol %endpos
537: kill-region
538:
539: ;bring it back if this is just a copy
540: !if %bkcopy
541: yank
542: !endif
543:
544: ;put the line in the block buffer
545: select-buffer "[block]"
546: yank
547:
548: ;and pad it if needed
549: !if &less $curcol %blwidth
550: &sub %blwidth $curcol insert-space
551: end-of-line
552: !endif
553: forward-character
554:
555: ;onward...
556: select-buffer %rcbuf
557: next-line
558: !endwhile
559:
560: ;unmark the block
561: select-buffer "[block]"
562: unmark-buffer
563: select-buffer %rcbuf
564: previous-line
565: %cline redraw-display
566: set $discmd TRUE
567: !endm
568:
569: ; insert/overlay a rectangular block of text
570:
571: store-procedure putblock
572: ;set up needed variables
573: set $discmd FALSE
574: set %rcbuf $cbufname
575: set %cline $cwline
576:
577: ;save block boundries
578: set %begpos $curcol
579: set %begline $curline
580:
581: ;scan through the block
582: select-buffer "[block]"
583: beginning-of-file
584: set %endpos &add %begpos $lwidth
585: !while ¬ &equ $lwidth 0
586:
587: ;pad the destination if it is needed
588: select-buffer %rcbuf
589: beginning-of-line
590: !if ¬ &equ $lwidth 0
591: 1 detab-line
592: previous-line
593: !endif
594: !force set $curcol %begpos
595: !if &less $curcol %begpos
596: &sub %begpos $curcol insert-space
597: end-of-line
598: !endif
599:
600: ;delete some stuff if this should overlay
601: !if %bkcopy
602: set-mark
603: !force set $curcol %endpos
604: kill-region
605: !endif
606:
607: ;grab the line from the block buffer
608: select-buffer "[block]"
609: beginning-of-line
610: set-mark
611: end-of-line
612: copy-region
613: forward-character
614:
615: ;put the line in the destination position
616: select-buffer %rcbuf
617: yank
618: next-line
619:
620: ;onward...
621: select-buffer "[block]"
622: !endwhile
623:
624: select-buffer %rcbuf
625: set $curline %begline
626: set $curcol %begpos
627: %cline redraw-display
628: set $discmd TRUE
629: !endm
630:
631: ; and init some variables
632: set %rcltype 2
633: write-message "[Block mode loaded]"
634:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.