├── .gitignore
├── screenshot.png
├── lady-with-an-ermine.jpg
├── README.md
└── magic-buffer.el
/.gitignore:
--------------------------------------------------------------------------------
1 | /libpeerconnection.log
2 | /magic-buffer-tests.el
3 |
--------------------------------------------------------------------------------
/screenshot.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/sabof/magic-buffer/HEAD/screenshot.png
--------------------------------------------------------------------------------
/lady-with-an-ermine.jpg:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/sabof/magic-buffer/HEAD/lady-with-an-ermine.jpg
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # magic-buffer
2 | An executable cookbook, on how to (ab)use emacse's display engine. Feel free to add sections, or suggest improvements.
3 |
4 | 
5 |
6 | ## Trans-network autoload
7 | You can add the following snippet to your .emacs. It will download and install the latest version of magic-buffer on its firsts run.
8 |
9 | (defun magic-buffer ()
10 | (interactive)
11 | (let (( file-name
12 | (concat temporary-file-directory
13 | "magic-buffer.el"))
14 | ( try-downloading
15 | (lambda ()
16 | (url-copy-file
17 | "https://raw.githubusercontent.com/sabof/magic-buffer/master/magic-buffer.el"
18 | file-name t)
19 | (require 'magic-buffer file-name))))
20 | (condition-case nil
21 | (funcall try-downloading)
22 | (error (funcall try-downloading))))
23 | (magic-buffer))
24 |
25 | then
26 |
27 | M-x magic-buffer
28 |
--------------------------------------------------------------------------------
/magic-buffer.el:
--------------------------------------------------------------------------------
1 | ;;; magic-buffer.el --- -*- lexical-binding: t -*-
2 | ;;; Version: 0.1
3 | ;;; Author: sabof
4 | ;;; URL: https://github.com/sabof/magic-buffer
5 |
6 | ;;; Commentary:
7 |
8 | ;; The project is hosted at https://github.com/sabof/magic-buffer
9 | ;; The latest version, and all the relevant information can be found there.
10 | ;;
11 | ;; Some sections have comments such as this:
12 | ;;
13 | ;; (info "(elisp) Pixel Specification")
14 | ;;
15 | ;; If you place the cursor in the end, and press C-x C-e, it will take you to
16 | ;; the related info page.
17 |
18 | ;;; License:
19 |
20 | ;; This file is NOT part of GNU Emacs.
21 | ;;
22 | ;; This program is free software; you can redistribute it and/or
23 | ;; modify it under the terms of the GNU General Public License as
24 | ;; published by the Free Software Foundation; either version 2, or (at
25 | ;; your option) any later version.
26 | ;;
27 | ;; This program is distributed in the hope that it will be useful, but
28 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of
29 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
30 | ;; General Public License for more details.
31 | ;;
32 | ;; You should have received a copy of the GNU General Public License
33 | ;; along with this program ; see the file COPYING. If not, write to
34 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
35 | ;; Boston, MA 02111-1307, USA.
36 |
37 | ;;; Code:
38 |
39 | (require 'cl-lib)
40 | (require 'color)
41 | (require 'info) ; For title faces
42 |
43 | ;;; * Library ------------------------------------------------------------------
44 | ;; Functions potentially useful in other contexts
45 |
46 | (defun mb-in-range (number from to)
47 | "Test whether a number is in FROM \(inclusive\) TO \(exclusive\) range."
48 | (and (<= from number) (< number to)))
49 |
50 | (defun mb-table-asciify-char (char)
51 | "Convert UTF8 table characters to their ASCII equivalents.
52 | If a character is not a table character, it will be left unchanged."
53 | ;; All table characters belong to the range 9472 inclusive - 9600 exclusive,
54 | ;; The comment contains the first character of each range
55 | (cond ( (mb-in-range char 9472 9474) ?-) ; ─
56 | ( (mb-in-range char 9474 9476) ?|) ; │
57 | ( (mb-in-range char 9476 9478) ?-) ; ┄
58 | ( (mb-in-range char 9478 9480) ?|) ; ┆
59 | ( (mb-in-range char 9480 9482) ?-) ; ┈
60 | ( (mb-in-range char 9482 9484) ?|) ; ┊
61 | ( (mb-in-range char 9484 9500) ?-) ; ┌
62 | ( (mb-in-range char 9500 9508) ?|) ; ├
63 | ( (mb-in-range char 9508 9516) ?|) ; ┤
64 | ( (mb-in-range char 9516 9524) ?-) ; ┬
65 | ( (mb-in-range char 9524 9532) ?-) ; ┴
66 | ( (mb-in-range char 9532 9548) ?+) ; ┼
67 | ( (mb-in-range char 9548 9550) ?-) ; ╌
68 | ( (mb-in-range char 9550 9552) ?|) ; ╎
69 | ( (member char '(?═ ?╒ ?╔ ?╕ ?╗ ?╘ ?╚ ?╛ ?╝)) ?=)
70 | ( (member char '(?║ ?╓ ?╖ ?╙ ?╜)) ?-)
71 | ( (member char '(?╞ ?╠ ?╡ ?╣ ?╤ ?╦ ?╧ ?╩ ?╪ ?╬)) ?=)
72 | ( (member char '(?╟ ?╢ ?╥ ?╨ ?╫)) ?-)
73 | ( (member char '(?╭ ?╯ ?╱)) ?/)
74 | ( (member char '(?╮ ?╰ ?╲)) (string-to-char "\\"))
75 | ( (= char ?╳) ?X)
76 | ( (mb-in-range char 9588 9600)
77 | (if (cl-evenp char) ?- ?|))
78 | ( t char)))
79 |
80 | (defun mb-table-asciify-string (string)
81 | "Convert an UTF8 table to an ASCII table.
82 | Accepts two numeric arguments, and will replace charactres in the
83 | the corresponding region of the buffer."
84 | (cl-loop for char across string
85 | collect (or (mb-table-asciify-char char)
86 | char)
87 | into char-list
88 | finally return (apply 'string char-list)))
89 |
90 | (defun mb-table-asciify-region (from to)
91 | (save-excursion
92 | (goto-char from)
93 | (insert-and-inherit
94 | (mb-table-asciify-string
95 | (delete-and-extract-region from to)))))
96 |
97 | (defun mb-table-insert (string)
98 | "Insert a table with UTF8 table borders, replacing them with ASCII
99 | fallbacks, if needed."
100 | (let ((start-pos (point))
101 | end-pos)
102 | (condition-case error
103 | (progn
104 | (cl-loop for char across string
105 | do
106 | (cl-assert (char-displayable-p char)))
107 | (insert string)
108 | (setq end-pos (point))
109 | (goto-char start-pos)
110 | (let (( regions (cl-loop while (< (point) end-pos)
111 | collecting (car (mb-posn-at-point
112 | (line-end-position)))
113 | until (cl-plusp (forward-line)))))
114 | (cl-assert (cl-every (apply-partially '= (car regions))
115 | regions)))
116 | (goto-char end-pos))
117 | (error (mb-table-asciify-region
118 | start-pos end-pos)
119 | ))))
120 |
121 | (defun mb-colorize-string-chars (string)
122 | (cl-loop for i from 0 to (1- (length string))
123 | do (put-text-property
124 | i (1+ i) 'face (append `(:background ,(mb-theme-color-source))
125 | (get-text-property i 'face string))
126 | string))
127 | string)
128 |
129 | (defun mb-random-hex-color ()
130 | (apply 'format "#%02X%02X%02X"
131 | (mapcar 'random (make-list 3 255))))
132 |
133 | (defun mb-kick-cursor (old new)
134 | (cond ( (and (< old new) (not (= (point-max) (point))))
135 | (forward-char 1))
136 | ( (and (not (< old new)) (not (= (point-min) (point))))
137 | (forward-char -1))))
138 |
139 | (defmacro mb-with-adjusted-enviroment (&rest body)
140 | (declare (indent defun))
141 | `(save-excursion
142 | (cond ( (get 'mb-with-adjusted-enviroment 'active)
143 | ,@body)
144 | ( (eq (current-buffer) (window-buffer))
145 | (let (( initial-start (window-start)))
146 | (prog1 (progn ,@body)
147 | (set-window-start nil initial-start))))
148 | ( t (unwind-protect
149 | (save-window-excursion
150 | (set-window-buffer nil (current-buffer))
151 | (put 'mb-with-adjusted-enviroment 'active t)
152 | ,@body)
153 | (put 'mb-with-adjusted-enviroment 'active nil))))))
154 |
155 | (defun mb-posn-at-point (&optional pos)
156 | (unless pos
157 | (setq pos (point)))
158 | (mb-with-adjusted-enviroment
159 | (goto-char pos)
160 | (or (posn-x-y (posn-at-point pos))
161 | (progn
162 | (goto-char (line-beginning-position))
163 | (set-window-start nil (point))
164 | (goto-char pos)
165 | (posn-x-y (posn-at-point pos))))))
166 |
167 | (defun mb-region-pixel-width (from to)
168 | "Find a region's pixel "
169 | (mb-with-adjusted-enviroment
170 | (let (( from (car (mb-posn-at-point from)))
171 | ( to (car (mb-posn-at-point to))))
172 | (- to from))))
173 |
174 | (defun mb-window-inside-pixel-width (&optional window)
175 | (setq window (window-normalize-window window))
176 | (let (( window-pixel-edges (window-inside-pixel-edges)))
177 | (- (nth 2 window-pixel-edges) (nth 0 window-pixel-edges))))
178 |
179 | (defun mb-window-inside-pixel-height (&optional window)
180 | (setq window (window-normalize-window window))
181 | (let (( window-pixel-edges (window-inside-pixel-edges)))
182 | (- (nth 3 window-pixel-edges) (nth 1 window-pixel-edges))))
183 |
184 | (defun mb-put-halign-overlay (from to &rest properties)
185 | (setq properties
186 | (append (list 'window (selected-window)
187 | 'mb-hcenterer (selected-window))
188 | properties))
189 | (let ((ov (make-overlay from to)))
190 | (while properties
191 | (overlay-put ov (pop properties) (pop properties)))
192 | ov))
193 |
194 | (defun mb-align-variable-width (&optional right)
195 | (mb-with-adjusted-enviroment
196 | ;; Add protection against negative aligmnets
197 | (beginning-of-visual-line)
198 | (let* (( beginning-of-visual-line
199 | (point))
200 | ( end-of-visual-line
201 | (save-excursion
202 | (end-of-visual-line)
203 | ;; (when (and right (/= (line-end-position) (point)))
204 | ;; (skip-chars-backward " " beginning-of-visual-line))
205 | ;; (sit-for 0.5)
206 | (point)))
207 | ( split-line (/= (line-end-position) end-of-visual-line))
208 | ( split-at-limit
209 | (and split-line
210 | (/= (cdr (mb-posn-at-point end-of-visual-line))
211 | (cdr (mb-posn-at-point (point))))))
212 | ( pixel-width
213 | (if split-at-limit
214 | (- (mb-window-inside-pixel-width)
215 | (car (mb-posn-at-point)))
216 | (mb-region-pixel-width
217 | (point)
218 | end-of-visual-line)))
219 | ( align-spec (if right
220 |
221 | ;; Full-width lines will break, when word-wrap is
222 | ;; enabled. That's why I leave some space in the
223 | ;; end.
224 | ;; http://debbugs.gnu.org/cgi/bugreport.cgi?2749
225 |
226 | `(space :align-to
227 | (- right (,pixel-width)
228 | ,(if word-wrap 2.0 0)
229 | ))
230 | `(space :align-to
231 | (- center (,(/ pixel-width 2))
232 | ;; Didn't seem to be necessary so far.
233 |
234 | ;; ,(if word-wrap 1.0 0)
235 | )))))
236 | ;; (message "split: %s at limit: %s" split-line split-at-limit)
237 | ;; (sit-for 0.5)
238 | (if (= (point) (line-beginning-position))
239 | (if (looking-at "[\t ]+")
240 | (progn
241 | (mb-put-halign-overlay
242 | (match-beginning 0)
243 | (match-end 0)
244 | 'display align-spec))
245 | (mb-put-halign-overlay
246 | (line-beginning-position)
247 | (line-end-position)
248 | 'before-string
249 | (propertize " " 'display align-spec)))
250 | (if (looking-at "[\t ]+") ; in the middle of a logical line
251 |
252 | ;; In some cases, when a line is almost equal to the window's
253 | ;; width, and it ends with an align-to spec, it will belong to the
254 | ;; next line, while being centered to the previous, resulting in
255 | ;; that character's disappearance. Or something like that. Might
256 | ;; try to reproduce it later.
257 |
258 | ;; This is mostly relevant for cases when truncate-lines is
259 | ;; non-nil, and word-wrap is nil -- a broken line with word-wrap
260 | ;; usually begins with a visible character.
261 |
262 | (if right
263 | (mb-put-halign-overlay
264 | (match-beginning 0)
265 | (match-end 0)
266 | 'display
267 | `(space :width (,(- (mb-window-inside-pixel-width)
268 | pixel-width))))
269 | (mb-put-halign-overlay
270 | (match-beginning 0)
271 | (match-end 0)
272 | 'display
273 | `(space :width (,(/ (- (mb-window-inside-pixel-width)
274 | pixel-width)
275 | 2)))))
276 | (mb-put-halign-overlay
277 | beginning-of-visual-line
278 | end-of-visual-line
279 | 'before-string
280 | (concat "\n" (propertize " " 'display align-spec)))))
281 | ;; (sit-for 0.5)
282 |
283 | ;; Frame width 65
284 | ;; (error "test")
285 | pixel-width
286 | )))
287 |
288 | (defvar mb-buffer-auto-align-markers
289 | '((right/center (marker) (marker)))
290 | )
291 |
292 | (defun mb-align-regions-horizontally-do (&optional all-windows)
293 | (cl-dolist (win (if all-windows
294 | (get-buffer-window-list)
295 | (list (selected-window))))
296 | ;; (with-selected-window win
297 | ;; (cl-loop for (type start end) in mb-buffer-auto-align-markers
298 | ;; do
299 | ;; ))
300 | ))
301 |
302 | (defun mb-auto-align-region-horizontally ()
303 | (add-hook 'window-configuration-change-hook 'ignore)
304 | (add-hook 'post-command-hook 'ignore))
305 |
306 | (defun mb-delete-subsequence (from to list)
307 | (let (( after-to (nthcdr to list)))
308 | (if (zerop from)
309 | after-to
310 | (progn
311 | (setcdr (nthcdr (1- from) list) after-to)
312 | list))))
313 |
314 | (defun mb-plist-remove-key (key plist)
315 | (let ((pos (cl-position key plist)))
316 | (if pos
317 | (mb-delete-subsequence
318 | pos (+ 2 pos) plist)
319 | plist)))
320 |
321 | (defun mb-show-in-two-columns (outer-margins inner-border rows)
322 | (cl-dolist (row rows)
323 | (insert (propertize " " 'display `(space :align-to ,outer-margins))
324 | (car row)
325 | (apply 'propertize " "
326 | 'display `(space :align-to (- center (,inner-border . 0.5)))
327 | (mb-plist-remove-key
328 | 'display (text-properties-at
329 | 0 (car row))))
330 | (propertize " "
331 | 'display `(space :width ,inner-border)
332 | )
333 | (nth 1 row)
334 | (apply 'propertize " "
335 | 'display `(space :align-to (- right ,outer-margins))
336 | (mb-plist-remove-key
337 | 'display (text-properties-at
338 | 0 (nth 1 row))))
339 | (apply 'propertize "\n" (car (last row))))))
340 |
341 | (defun mb-content-height ()
342 | (let (added-newline)
343 | (mb-with-adjusted-enviroment
344 | (with-silent-modifications
345 | (set-window-start nil (point-min))
346 | (goto-char (point-max))
347 | (unless (or (equal (char-before) ?\n )
348 | (= (point-min) (point-max)))
349 | (insert "\n")
350 | (setq added-newline t))
351 | (prog1 (cdr (posn-x-y (posn-at-point)))
352 | (when added-newline
353 | (delete-char -1)))
354 | ))))
355 |
356 | (defvar mb-centerv nil)
357 |
358 | (defun mb-virtualize-overlay (ov)
359 | (prog1 (append (list (overlay-start ov) (overlay-end ov))
360 | (overlay-properties ov))
361 | (delete-overlay ov)))
362 |
363 | (let (( colors
364 | (sort (mapcar (lambda (face)
365 | (face-attribute face :foreground))
366 | '(font-lock-string-face
367 | font-lock-keyword-face
368 | font-lock-comment-face
369 | font-lock-variable-name-face
370 | font-lock-function-name-face))
371 | (lambda (a b)
372 | (zerop (random 2)))))
373 | expendable-colors)
374 | (defun mb-theme-color-source ()
375 | (unless expendable-colors
376 | (setq expendable-colors colors))
377 | (pop expendable-colors)))
378 |
379 | (defun mb-realize-overlay (ov-spec)
380 | (cl-destructuring-bind
381 | (start end &rest props)
382 | ov-spec
383 | (let ((ov (make-overlay start end)))
384 | (while props (overlay-put ov (pop props) (pop props)))
385 | ov)))
386 |
387 | (cl-defun mb-insert-bordered-text (text &key (border-width 3)
388 | (horizontal-margins 20)
389 | (padding 5)
390 | (border-color "DarkRed")
391 | (right-align-spec 'right))
392 | (let* (( segment-left-margin
393 | (lambda (&optional additonal-specs)
394 | (propertize " "
395 | 'display `(space :align-to (,horizontal-margins)
396 | ,@additonal-specs))))
397 | ( segment-filler
398 | (lambda (&optional additonal-specs)
399 | (propertize " "
400 | 'display `(space :align-to
401 | (- ,right-align-spec
402 | (,border-width)
403 | (,horizontal-margins))
404 | ,@additonal-specs))))
405 | ( segment-lr-border
406 | (lambda (&optional additonal-specs)
407 | (propertize " " 'display `(space :width (,border-width)
408 | ,@additonal-specs)
409 | 'face `(:background ,border-color))))
410 | ( segment-lr-padding
411 | (lambda ()
412 | (propertize " " 'display `(space :width (,padding)))))
413 | ( segment-tb-border
414 | (lambda ()
415 | (propertize
416 | (concat
417 | (funcall segment-left-margin `(:height (,border-width)))
418 | (propertize " "
419 | 'display `(space :align-to
420 | (- ,right-align-spec
421 | (,horizontal-margins))
422 | :height (,border-width))
423 | 'face `(:background ,border-color))
424 | (propertize "\n" 'line-height t))
425 | 'point-entered 'mb-kick-cursor)))
426 | ( segment-tb-padding
427 | (lambda ()
428 | (propertize
429 | (concat
430 | (funcall segment-left-margin `(:height (,padding)))
431 | (funcall segment-lr-border `(:height (,padding)))
432 | (funcall segment-filler `(:height (,padding)))
433 | (funcall segment-lr-border `(:height (,padding)))
434 | (propertize "\n" 'line-height t))
435 | 'point-entered 'mb-kick-cursor)))
436 | ( segment-line
437 | (lambda (text)
438 | (concat (propertize
439 | (concat
440 | (funcall segment-left-margin)
441 | (funcall segment-lr-border)
442 | (funcall segment-lr-padding))
443 | 'point-entered 'mb-kick-cursor)
444 | (propertize text
445 | 'wrap-prefix
446 | (concat (funcall segment-left-margin)
447 | (funcall segment-lr-border)
448 | (funcall segment-lr-padding)))
449 | (propertize
450 | (concat
451 | (funcall segment-filler)
452 | (funcall segment-lr-border)
453 | "\n")
454 | 'point-entered 'mb-kick-cursor)))))
455 |
456 | (insert (funcall segment-tb-border)
457 | (funcall segment-tb-padding))
458 | (mapc (lambda (line) (insert (funcall segment-line line)))
459 | (split-string text "\n"))
460 | (insert (funcall segment-tb-padding)
461 | (funcall segment-tb-border))
462 | ))
463 |
464 | (cl-defun mb-insert-shadowed-text
465 | (text &key (horizontal-margins 20)
466 | (padding 5)
467 | (shadow-distance 5)
468 | (background-color "DarkRed")
469 | (right-align-spec 'right))
470 | (let* (;; Legacy stuff
471 | (border-width 5)
472 |
473 | ( stipple
474 | ;; Everything can be converted to bits, so as far as I can tell,
475 | ;; everything will work.
476 | '(2 2 "a
477 | a"))
478 | ( segment-left-margin
479 | (lambda (&optional additonal-specs)
480 | (propertize " "
481 | 'display `(space :align-to (,horizontal-margins)
482 | ,@additonal-specs))))
483 | ( segment-filler
484 | (lambda (&optional additonal-specs)
485 | (propertize " "
486 | 'display `(space :align-to
487 | (- ,right-align-spec
488 | (,border-width)
489 | (,horizontal-margins))
490 | ,@additonal-specs)
491 | 'face `(:background ,background-color))))
492 | ( segment-r-shadow
493 | (lambda (&optional additonal-specs)
494 | (propertize " " 'display `(space :width (,border-width)
495 | ,@additonal-specs)
496 | 'face `(:foreground "Black" :stipple ,stipple))))
497 |
498 | ( segment-lr-padding
499 | (lambda ()
500 | (propertize " " 'display `(space :width (,padding))
501 | 'face `(:background ,background-color))))
502 | ( segment-b-shadow
503 | (lambda ()
504 | (propertize
505 | (concat
506 | (funcall segment-left-margin `(:height (,border-width)))
507 | (propertize " "
508 | 'display `(space :align-to
509 | (- ,right-align-spec
510 | (,horizontal-margins))
511 | :height (,shadow-distance)
512 | :width (,shadow-distance)))
513 | (propertize " "
514 | 'display `(space :align-to
515 | (- ,right-align-spec
516 | (,horizontal-margins))
517 | :height (,shadow-distance))
518 | 'face `(:foreground "Black" :stipple ,stipple))
519 | (propertize "\n" 'line-height t))
520 | ;; 'point-entered 'mb-kick-cursor
521 | )))
522 | ( segment-tb-padding
523 | (lambda ()
524 | (propertize
525 | (concat
526 | (funcall segment-left-margin `(:height (,padding)))
527 | (funcall segment-filler `(:height (,padding))))
528 | ;; 'point-entered 'mb-kick-cursor
529 | )))
530 | ( segment-line
531 | (lambda (text)
532 | (concat (propertize
533 | (concat
534 | (funcall segment-left-margin)
535 | (funcall segment-lr-padding))
536 | ;; 'point-entered 'mb-kick-cursor
537 | )
538 | (propertize text
539 | 'wrap-prefix
540 | (concat (funcall segment-left-margin)
541 | (funcall segment-r-shadow)
542 | (funcall segment-lr-padding))
543 | 'face `(:background ,background-color))
544 | (propertize
545 | (concat
546 | (funcall segment-filler)
547 | (funcall segment-r-shadow)
548 | "\n")
549 | ;; 'point-entered 'mb-kick-cursor
550 | )))))
551 |
552 | (insert ;; (funcall segment-b-shadow)
553 | (funcall segment-tb-padding)
554 | (propertize "\n" 'line-height t))
555 | (mapc (lambda (line) (insert (funcall segment-line line)))
556 | (split-string text "\n"))
557 | (insert (funcall segment-tb-padding)
558 | (funcall segment-r-shadow `(:height (,padding)))
559 | (propertize "\n" 'line-height t)
560 | (funcall segment-b-shadow)
561 | )
562 | ))
563 |
564 | (cl-defun mb--recenter-buffer-vertically (&optional dont-recenter)
565 | (let* (content-height
566 | ( window-height (mb-window-inside-pixel-height))
567 | ( inhibit-read-only t)
568 | ( old-overlays
569 | (cl-remove-if-not
570 | (lambda (ov)
571 | (and (overlay-get ov 'mb-vcenterer)
572 | (overlay-get ov 'mb-hcenterer)
573 | (eq (overlay-get ov 'window)
574 | (selected-window))))
575 | (overlays-at (point-min))))
576 | ( old-before-string
577 | (and (car old-overlays)
578 | (overlay-get (car old-overlays) 'mb-hcenterer)
579 | (overlay-get (car old-overlays) 'before-string)))
580 | ( old-horizontal-centering
581 | (or (and old-before-string
582 | (string-match " " old-before-string)
583 | (get-text-property (match-beginning 0) 'display
584 | old-before-string))
585 | ""))
586 | new-before-string
587 | new-ov)
588 | (mapc 'delete-overlay old-overlays)
589 | (unless (setq content-height (mb-content-height))
590 | (cl-return-from mb--recenter-buffer-vertically nil))
591 | (setq new-before-string
592 | (concat (when content-height
593 | (propertize "\n"
594 | 'line-height
595 | (/ (- window-height
596 | content-height) 2)))
597 | old-horizontal-centering))
598 | (when (not (string= "" new-before-string))
599 | (setq new-ov (make-overlay
600 | (point-min)
601 | (min (point-max)
602 | (1+ (point-min)))))
603 | (overlay-put new-ov 'mb-centerer t)
604 | ;; (overlay-put new-ov 'read-only t)
605 | (overlay-put new-ov 'window (selected-window))
606 | (overlay-put new-ov 'before-string new-before-string))
607 | (unless dont-recenter
608 | (set-window-start nil (point-min)))))
609 |
610 | (cl-defun mb-center-buffer-vertically (&optional (buffer (current-buffer)))
611 | "Inserts a newline character in the beginning of the buffer,
612 | displayed in a way that will make the buffer appear vertically
613 | centered. Not meant to be used in \"writing\" buffers, where
614 | undo history is important."
615 | (with-current-buffer buffer
616 | (add-hook 'window-configuration-change-hook
617 | 'mb--recenter-buffer-vertically
618 | nil t)
619 | (add-hook 'post-command-hook
620 | 'mb--recenter-buffer-vertically
621 | nil t)
622 | (add-hook 'window-scroll-functions
623 | (lambda (&rest ignore)
624 | (mb--recenter-buffer-vertically t))
625 | nil t)
626 | ;; (add-hook 'window-scroll-functions 'mb--recenter-buffer nil t)
627 | ))
628 |
629 |
630 | (defun mb-clear-window-align-overlays ()
631 | (remove-overlays (window-start) (window-end nil t)
632 | 'mb-hcenterer-window (selected-window)))
633 |
634 | (defun mb-realign-hook ()
635 | (mb-clear-window-align-overlays)
636 | (goto-char (window-start))
637 | (let ((prop))
638 | (while (< (point) (window-end nil t))
639 | (setq prop (get-text-property mb-hcenterer (point))))))
640 |
641 | (define-minor-mode mb-alignment-mode
642 | "Doc" nil nil nil
643 | (if mb-alignment-mode
644 | (progn
645 | (add-hook))))
646 |
647 | ;;; * Helpers ------------------------------------------------------------------
648 | ;; Utilities that make this presentation possible
649 |
650 | (defvar mb-sections nil)
651 | (setq mb-sections nil)
652 | (defvar mb-counter 1)
653 | (setq mb-counter 1)
654 | (defvar mb--exclusive-section nil
655 | "Only show the section with a particular number.
656 | Created to ease development.")
657 | (defvar mb-expamle-image
658 | (or (and load-file-name
659 | (file-exists-p
660 | (concat
661 | (file-name-directory load-file-name)
662 | "lady-with-an-ermine.jpg"))
663 | (concat
664 | (file-name-directory load-file-name)
665 | "lady-with-an-ermine.jpg"))
666 | (and buffer-file-name
667 | (file-exists-p
668 | (concat
669 | (file-name-directory buffer-file-name)
670 | "lady-with-an-ermine.jpg"))
671 | (concat
672 | (file-name-directory buffer-file-name)
673 | "lady-with-an-ermine.jpg"))
674 | (let (( file-name
675 | (concat temporary-file-directory
676 | "lady-with-an-ermine.jpg")))
677 | (url-copy-file
678 | "https://raw.github.com/sabof/magic-buffer/master/lady-with-an-ermine.jpg"
679 | file-name t)
680 | file-name)))
681 |
682 | (defmacro mb-section (name &rest body)
683 | (declare (indent defun))
684 | `(let* (( cons (car (push (list (prog1 mb-counter
685 | (cl-incf mb-counter)))
686 | mb-sections))))
687 | (setcdr cons (list ,name
688 | ,(if (stringp (car body))
689 | (pop body)
690 | nil)
691 | (lambda ()
692 | ,@body)))))
693 |
694 | (defmacro mb-subsection (name &rest body)
695 | (declare (indent defun))
696 | `(progn
697 | (insert "\n" (propertize ,name 'face 'info-title-4) "\n")
698 | ,@body))
699 |
700 | (defun mb-insert-filled (string)
701 | (let ((beginning (point)))
702 | (insert string)
703 | (fill-region beginning (point))))
704 |
705 | (defun mb-comment (string)
706 | (mb-insert-filled (propertize string 'face '(:inherit (variable-pitch font-lock-comment-face))))
707 | (insert "\n"))
708 |
709 |
710 |
711 |
712 | (defmacro mb-insert-info-links (&rest links)
713 | `(progn
714 | (delete-char -1)
715 | ,@(mapcar (lambda (link)
716 | `(progn
717 | (insert-text-button ,(cadr link) 'action
718 | (lambda (e) (info ,(cadr link))))
719 | (insert (propertize " | " 'face 'bold))))
720 | links)
721 | (delete-char -3)
722 | (insert "\n")))
723 |
724 | ;;; * Sections ------------------------------------------------------------------
725 |
726 | (mb-section "Horizontal line"
727 | "The point-entered property prevents the point from staying on that location,
728 | since that would change the color of the line."
729 | (insert (propertize
730 | "\n"
731 | 'display `(space :align-to (- right (1)))
732 | 'face '(:underline t)
733 | 'point-entered 'mb-kick-cursor
734 | ))
735 | (insert "\n"))
736 |
737 | ;; -----------------------------------------------------------------------------
738 |
739 | (mb-section "Stipples / 2 columns / Line cursor"
740 | "Uses stipples that come with your unix distribution. They have \
741 | some re-drawing issues after scrolling."
742 | (let ((ori-point (point))
743 | grid-strings stipple-names
744 | ( grey-stipple
745 | '(2 2 "a
746 | a")))
747 | (cl-dolist (dir x-bitmap-file-path)
748 | (setq stipple-names
749 | (nconc
750 | stipple-names
751 | (cl-remove-if (lambda (file) (member file '(".." ".")))
752 | (directory-files dir)))))
753 | (setq stipple-names
754 | (sort stipple-names
755 | (lambda (&rest ignore)
756 | (zerop (random 2)))))
757 | (setq stipple-names
758 | (or (last stipple-names 12)
759 | (make-list 12 grey-stipple)))
760 | (while stipple-names
761 | (let* (( current-batch
762 | (list (pop stipple-names)
763 | (pop stipple-names))))
764 | (push (nconc (mapcar
765 | (lambda (name)
766 | (cond ( (not name)
767 | " ")
768 | ( (stringp name)
769 | (propertize name 'face
770 | '(:weight
771 | bold
772 | :inherit variable-pitch)))
773 | ( t "default")))
774 | current-batch)
775 | (list (list 'line-height 2.0)))
776 | grid-strings)
777 | (push (nconc (mapcar (lambda (stipple)
778 | (if stipple
779 | (propertize
780 | " " 'face
781 | `(:inherit
782 | font-lock-comment-face
783 | :stipple ,stipple))
784 | " "))
785 | current-batch)
786 | (list (list 'line-height 2.0)))
787 | grid-strings)))
788 | (setq tmp (length grid-strings))
789 | (setq grid-strings (nreverse grid-strings))
790 | (mb-show-in-two-columns '(20) 2 grid-strings)
791 | (backward-char)
792 | (setq-local face-remapping-alist
793 | `((hl-line (:background
794 | ,(apply 'format "#%02X%02X%02X"
795 | (mapcar (apply-partially '* 255)
796 | (color-complement
797 | (face-attribute 'cursor :background))))
798 | :inverse-video t))))
799 | (add-text-properties ori-point (point)
800 | (list 'point-entered (lambda (&rest ignore)
801 | (setq cursor-type nil)
802 | (hl-line-mode))
803 | 'point-left (lambda (&rest ignore)
804 | (setq cursor-type t)
805 | (hl-line-mode -1))))))
806 |
807 | ;; -----------------------------------------------------------------------------
808 |
809 | (mb-section "Differentiate displays"
810 | (mb-insert-info-links
811 | (info "(elisp) Defining Faces")
812 | (info "(elisp) Display Feature Testing"))
813 | (insert "\n")
814 | (defface mb-diff-terminal
815 | `(( ((type graphic))
816 | (:background ,(mb-theme-color-source)
817 | :foreground ,(face-attribute 'default :background)
818 | :weight bold))
819 |
820 | ( ((class color)
821 | (min-colors 88))
822 | (:background ,(mb-theme-color-source)
823 | :foreground ,(face-attribute 'default :background)
824 | :weight bold))
825 |
826 | ( ((class color)
827 | (min-colors 88))
828 | (:background ,(mb-theme-color-source)
829 | :foreground ,(face-attribute 'default :background)
830 | :weight bold))
831 |
832 | ( t (:background ,(mb-theme-color-source)
833 | :foreground ,(face-attribute 'default :background)
834 | :weight bold)
835 | ))
836 | "A face with different background, depending on type of display")
837 |
838 | (mb-insert-filled
839 | (propertize " This text will have a different background, depending on \
840 | the type of display (Graphical, tty, \"full color\" tty). "
841 | 'face 'mb-diff-terminal))
842 | (insert "\n"))
843 |
844 | ;; -----------------------------------------------------------------------------
845 |
846 | (mb-section "Differentiate windows"
847 | (mb-insert-info-links
848 | (info "(elisp) Overlay Properties"))
849 | (insert "\n")
850 | (let (( text " This text will have a different background color in each \
851 | window it is displayed ")
852 | ( window-list (list 'window-list))
853 | ( point-a (point))
854 | point-b)
855 | (insert text)
856 | (setq point-b (point))
857 | (add-hook 'window-configuration-change-hook
858 | (lambda (&rest ignore)
859 | (cl-dolist (win (get-buffer-window-list nil nil t))
860 | (unless (assoc win (cdr window-list))
861 | (let ((ov (make-overlay point-a point-b)))
862 | (setcdr window-list (cl-acons win ov (cdr window-list)))
863 | (overlay-put ov 'window win)
864 | (overlay-put ov 'face
865 | `(:background
866 | ,(mb-theme-color-source)
867 | :foreground ,(face-attribute 'default :background)
868 | :weight bold)))
869 | )))
870 | nil t)))
871 |
872 | ;; -----------------------------------------------------------------------------
873 |
874 | (mb-section "Aligning fixed width text"
875 | (mb-insert-info-links
876 | (info "(elisp) Pixel Specification"))
877 | (mb-comment "The alignment will persist on window resizing, unless the window is narrower
878 | than the text.")
879 | (let* (( text-lines (split-string
880 | "Reperiuntur quaeritur horrent nisi, summum solido animo
881 | Consequi quapropter e sed dolor ita fore
882 | Censes profecto legendos neque quid, omne laudantium putanda beatus philosophi
883 | Fieri quam ad nos et ut alios voluptatibus, statuam
884 | Cernantur individua ista dicam tua igitur philosophia amicitia numeranda arbitratu"
885 | "\n")))
886 | (mb-subsection "Center"
887 | (insert "\n")
888 | (cl-dolist (text text-lines)
889 | (let ((spec `(space :align-to (- center ,(/ (length text) 2)))))
890 | (insert (propertize text 'line-prefix
891 | (propertize " " 'display spec))
892 | "\n"))))
893 |
894 | (mb-subsection "Right"
895 | (insert "\n")
896 | (cl-dolist (text text-lines)
897 | (let ((spec `(space :align-to (- right ,(length text) (1)))))
898 | (insert (propertize text 'line-prefix
899 | (propertize " " 'display spec))
900 | "\n")))))
901 |
902 | (mb-subsection "Display on both sides of the window"
903 | (insert "\n")
904 | (let* (( text-left "LEFT --")
905 | ( text-right "-- RIGHT")
906 | ( spec `(space :align-to (- right ,(length text-right) (1)))))
907 | (insert text-left)
908 | (insert (propertize " " 'display spec))
909 | (insert text-right)
910 | )))
911 |
912 | ;; -----------------------------------------------------------------------------
913 |
914 | (mb-section "Aligning variable width text"
915 | (mb-insert-info-links
916 | (info "(elisp) Pixel Specification"))
917 | (mb-comment "Will break, should the size of frame's text
918 | change. If there are line breaks, the lines won't align after a
919 | window resize. *WIP*")
920 | (let* (( paragraphs "Omnino enim quidem concederetur, sapiens qua. Concessum \
921 | rerum non cum dicta iudiciorumque assecutus cum, nutu feci magnum
922 | Suscipiet tum, ista et dicenda cum
923 | Faciendum sine ut litterae sentit autem neque
924 | Partitio partes ea operosam te, doloris etiam
925 | De ad, quam, nam laboriosam hoc triarius, qua multo graecis aut")
926 | start end)
927 | (mb-subsection "Center"
928 | (insert "\n")
929 | (setq start (point))
930 | (cl-loop for text in (split-string paragraphs "\n")
931 | for height = 2.4 then (- height 0.4)
932 | for face-spec = `(:inherit variable-pitch :height ,height)
933 | do (insert (propertize text 'face face-spec) "\n"))
934 | (setq end (point))
935 | (let (virtual-overlays)
936 | ;; (vertical-motion) seems to misbehave when the buffer is burried
937 | ;; (mb-with-adjusted-enviroment) ensures that the buffer is displayed. It
938 | ;; also reduces multiple (save-window-excurson)s to one.
939 | (mb-with-adjusted-enviroment
940 | (goto-char start)
941 | (cl-loop while (< (point) end)
942 | do
943 | (mb-align-variable-width)
944 | (unless (cl-plusp (vertical-motion 1))
945 | (return)))))
946 | (goto-char (point-max)))
947 | (mb-subsection "Right"
948 | (insert "\n")
949 | (save-excursion
950 | (cl-loop for text in (split-string paragraphs "\n")
951 | for height = 1.0 then (+ height 0.4)
952 | for face-spec = `(:inherit variable-pitch :height ,height)
953 | do (insert (propertize text 'face face-spec) "\n"))
954 | (setq end (point)))
955 |
956 | (mb-with-adjusted-enviroment
957 | (cl-loop while (< (point) end)
958 | do
959 | (mb-align-variable-width 'right)
960 | (unless (cl-plusp (vertical-motion 1))
961 | (return)))))
962 | ))
963 |
964 | ;; -----------------------------------------------------------------------------
965 |
966 | (mb-section "Re-align after variable-width font lines"
967 | "Similar to what `fill-column-indicator' does. A similar effect
968 | can be achieved by setting `tab-width' to a large number, and
969 | splitting columns with tabs, but this will affect tabs in the
970 | whole buffer. The red line will move further to the right,
971 | should the preceeding text be long."
972 | (let* (( sentances (split-string
973 | "Lorem ipsum dolor sit amet, consectetuer adipiscing elit.
974 | Donec hendrerit tempor tellus.
975 | Donec pretium posuere tellus.
976 | Proin quam nisl, tincidunt et, mattis eget, convallis nec, purus.
977 | Cum sociis natoque penatibus et magnis dis parturient montes, nascetur ridiculus mus.
978 | Nulla posuere.
979 | Donec vitae dolor.
980 | Nullam tristique diam non turpis.
981 | Cras placerat accumsan nulla.
982 | Nullam rutrum.
983 | Nam vestibulum accumsan nisl."
984 | "\n"))
985 | ( spec `(space :align-to 80)))
986 | (cl-dolist (sentance sentances)
987 | (insert (propertize sentance 'face `(:inherit
988 | variable-pitch
989 | :height ,(+ 1.0 (/ (random 10) 10.0))))
990 | (propertize " " 'display spec)
991 | (propertize " " 'face '(:background "DarkRed")
992 | 'display '(space :width (3)))
993 | " More text"
994 | "\n"))))
995 |
996 | ;; -----------------------------------------------------------------------------
997 |
998 | ;; (mb-section "Center horizontally and vertically"
999 | ;; (insert-button "Show in new buffer"
1000 | ;; 'action (lambda (e)
1001 | ;; (switch-to-buffer
1002 | ;; (get-buffer-create
1003 | ;; "*magic-buffer-hv-centering*"))
1004 | ;; (let ((inhibit-read-only t))
1005 | ;; (erase-buffer)
1006 | ;; (insert "test")
1007 | ;; (mb-center-line-variable-width))
1008 | ;; (unless view-mode
1009 | ;; (view-mode 1))
1010 | ;; ))
1011 | ;; )
1012 |
1013 | ;; -----------------------------------------------------------------------------
1014 |
1015 | (mb-section "Utf-8 tables"
1016 | "Some fonts don't support box characters well, for example the
1017 | widths might be different. For those cases an ASCII fallback is
1018 | provided. If you know which widely used fonts apart from
1019 | \"DejaVu Sans Mono\" render correctly, please let me know.
1020 |
1021 | Spaces might appear between characters, especially with smaller font sizes.
1022 |
1023 | A table of unicode box characters can be found in the source code."
1024 |
1025 | ;; ─ ━ │ ┃ ┄ ┅ ┆ ┇ ┈ ┉ ┊ ┋ ┌ ┍ ┎ ┏
1026 |
1027 | ;; ┐ ┑ ┒ ┓ └ ┕ ┖ ┗ ┘ ┙ ┚ ┛ ├ ┝ ┞ ┟
1028 |
1029 | ;; ┠ ┡ ┢ ┣ ┤ ┥ ┦ ┧ ┨ ┩ ┪ ┫ ┬ ┭ ┮ ┯
1030 |
1031 | ;; ┰ ┱ ┲ ┳ ┴ ┵ ┶ ┷ ┸ ┹ ┺ ┻ ┼ ┽ ┾ ┿
1032 |
1033 | ;; ╀ ╁ ╂ ╃ ╄ ╅ ╆ ╇ ╈ ╉ ╊ ╋ ╌ ╍ ╎ ╏
1034 |
1035 | ;; ═ ║ ╒ ╓ ╔ ╕ ╖ ╗ ╘ ╙ ╚ ╛ ╜ ╝ ╞ ╟
1036 |
1037 | ;; ╠ ╡ ╢ ╣ ╤ ╥ ╦ ╧ ╨ ╩ ╪ ╫ ╬ ╭ ╮ ╯
1038 |
1039 | ;; ╰ ╱ ╲ ╳ ╴ ╵ ╶ ╷ ╸ ╹ ╺ ╻ ╼ ╽ ╾ ╿
1040 |
1041 | ;; Taken from https://en.wikipedia.org/wiki/Box_Drawing_(Unicode_block)
1042 |
1043 | (let ((table1 (substring "
1044 | ╔══════╤══════╗
1045 | ║ text │ text ║
1046 | ╟──────┼──────╢
1047 | ║ text │ text ║
1048 | ╚══════╧══════╝
1049 | "
1050 | 1))
1051 | (table2 (substring "
1052 | ╭──────┰──────╮
1053 | │ text ┃ text │
1054 | ┝━━━━━━╋━━━━━━┥
1055 | │ text ┃ text │
1056 | ╰──────┸──────╯
1057 | "
1058 | 1)))
1059 |
1060 | ;; In an application, especially one that where the content changes
1061 | ;; frequently, it would probably be better to determine whether all used
1062 | ;; table characters have equal width with letters once, and then use them or
1063 | ;; ASCII accordingly. This would be noticably faster.
1064 |
1065 | (mb-table-insert
1066 | (propertize table1 'face '(:height 1.4 :family "DejaVu Sans Mono")))
1067 | (mb-table-insert
1068 | (propertize table2 'face '(:height 1.4 :family "DejaVu Sans Mono")))
1069 | ))
1070 |
1071 | ;; -----------------------------------------------------------------------------
1072 |
1073 | (mb-section "Decorated paragraphs"
1074 | (let (( prefix (concat (propertize " " 'display '(space :width (20)))
1075 | (propertize " " 'display '(space :width (3))
1076 | 'face '(:background "DarkRed"))
1077 | (propertize " " 'display '(space :width (5))))))
1078 |
1079 | (mb-subsection "Paragraph with a single line"
1080 | (mb-comment "The red line is drawn using text-properties, so the text can
1081 | be copy-pasted without extra spaces.")
1082 | (insert "\n")
1083 | (mb-insert-filled
1084 | (propertize "Nixam aliquando efficiat, omittendis ad, aliter similia hominem exitum, temeritate.
1085 | Disserendum neque fortasse, consequantur illud et erat potest voluptas temperantiam isdem.
1086 | Quod mihi loca consilio ipsius, aliae quo voluptatis.
1087 | Quod nisi litteras fieri posuit torquate expetendam cum."
1088 | 'wrap-prefix prefix
1089 | 'line-prefix prefix
1090 | 'face '(:slant italic :inherit variable-pitch)))
1091 | (insert "\n"))
1092 |
1093 | (mb-subsection "Boxes"
1094 | (mb-comment "Should the contained text exceed the width of the box, gaps
1095 | will appear in the right border.")
1096 | (insert "\n")
1097 | (mb-insert-bordered-text
1098 | (propertize "Falsi autem ut constituto tarentinis, sapientiam.
1099 | Eoque integris ennius morborum impensa quadam quae apud provocatus, cum."
1100 | 'face 'variable-pitch))
1101 |
1102 | (insert "\n")
1103 | (mb-insert-shadowed-text
1104 | (propertize "Plane amicos sed enim, eruditi voluptate honestatis dolemus inermis, athenis.
1105 | Si propemodum consecutus posse operam facillime accurate quae suavitate te.
1106 | Quasi reperiri ad parta quae semper scripta a etiam malum."
1107 | 'face `(:foreground ,(face-attribute 'default :background)))
1108 | :background-color "DarkCyan"
1109 | ;; :padding 15
1110 | ))
1111 |
1112 | (mb-subsection "Extra leading"
1113 | (mb-comment "The line-height property only has effect when applied to newline characters.")
1114 | (insert "\n")
1115 | (insert (propertize "Sollicitudines regione finiri est inpotenti patria, dolorum morati omnino latinas.
1116 | Ullam ipso tot assentior ita etiam.
1117 | Etiamsi facio illas et notissima et bonis quod semper disserendi alias.
1118 | Ab beateque omnem in humili, mandamus potest constituant amicitia, quoniam.
1119 | "
1120 | 'face 'variable-pitch
1121 | 'line-height 1.5
1122 | )))
1123 | ))
1124 |
1125 | ;; -----------------------------------------------------------------------------
1126 |
1127 | (mb-section "Fringe indicators"
1128 | (mb-insert-info-links
1129 | (info "(elisp) Fringe Indicators"))
1130 | (mb-comment "fringe-indicator-alist contains the default indicators. The easiest way to
1131 | make new ones is to use an external package called `fringe-helper'.")
1132 | (insert "\n")
1133 | (let (( insert-fringe-bitmap
1134 | (lambda (symbol-name)
1135 | (insert (propertize " " 'display
1136 | `((left-fringe ,symbol-name font-lock-comment-face)
1137 | (right-fringe ,symbol-name font-lock-comment-face)))))))
1138 | (cl-loop for pair in fringe-indicator-alist
1139 | for iter = 0 then (1+ iter)
1140 | do
1141 | (unless (zerop iter)
1142 | (insert "\n"))
1143 | (insert (propertize (concat "✸ " (symbol-name (car pair)))
1144 | 'face 'info-title-4)
1145 | "\n")
1146 | (if (symbolp (cdr pair))
1147 | (progn
1148 | (funcall insert-fringe-bitmap (cdr pair))
1149 | (insert (concat " " (symbol-name (cdr pair))) "\n"))
1150 | (cl-dolist (bitmap (cdr pair))
1151 | (progn
1152 | (funcall insert-fringe-bitmap bitmap)
1153 | (insert (concat " " (symbol-name bitmap)) "\n"))))
1154 | )))
1155 |
1156 | ;; -----------------------------------------------------------------------------
1157 |
1158 | (mb-section "Pointer shapes"
1159 | (mb-insert-info-links
1160 | (info "(elisp) Pointer Shape"))
1161 | (mb-comment "Hover with your mouse over the labels to change the pointer.")
1162 | (insert "\n")
1163 | (mapc (lambda (pointer-sym)
1164 | (insert " "
1165 | (propertize
1166 | (concat " " (symbol-name pointer-sym) " ")
1167 | 'pointer pointer-sym
1168 | 'face `(:height 1.0
1169 | :background ,(face-attribute 'font-lock-keyword-face
1170 | :foreground)
1171 | :inherit variable-pitch)
1172 | 'mouse-face '(:height 1.0
1173 | :background "#888"
1174 | :foreground "black"
1175 | :inherit variable-pitch))))
1176 | '(text arrow hand vdrag hdrag modeline hourglass))
1177 |
1178 | ;; As far as I was able to tell, this line-height format translates to
1179 | ;; ((+ TEXT-HEIGHT TOP) (+ TEXT-HEIGHT BOTTOM))
1180 | ;; the line-height info page is wrong
1181 |
1182 | (insert (propertize "\n" 'line-height '(1.5 1.5))))
1183 |
1184 | ;; -----------------------------------------------------------------------------
1185 |
1186 | (mb-section "Images"
1187 | (mb-insert-info-links
1188 | (info "(elisp) Showing Images")
1189 | (info "(elisp) Image Descriptors"))
1190 | (mb-comment "Scrolling generally misbehaves with images. Presumably `insert-sliced-image'
1191 | was made to improve the situation, but it makes things worse on occasion.")
1192 | (let (( image-size
1193 | ;; For terminal displays
1194 | (ignore-errors (image-size `(image :type jpeg
1195 | :file ,mb-expamle-image)
1196 | t))))
1197 | (mb-subsection "Simple case"
1198 | (insert "\n")
1199 | (insert-image `(image :type jpeg
1200 | :file ,mb-expamle-image)
1201 | "[you should be seeing an image]")
1202 | (insert "\n\n")
1203 | (when image-size
1204 | (mb-subsection "Using `insert-sliced-image'"
1205 | (mb-comment "point-entered hook is used,
1206 | to prevent a box from showing around individual slices.")
1207 | (insert "\n")
1208 | (let (( start (point)))
1209 | (insert-sliced-image `(image :type jpeg
1210 | :file ,mb-expamle-image)
1211 | "[you should be seeing an image]"
1212 | nil (max 1 (1- (/ (car image-size)
1213 | (frame-char-height)))))
1214 | (goto-char start)
1215 | (cl-loop until (= (point) (point-max))
1216 | for segment in (list "You can also add text next to"
1217 | "sliced images. The technique"
1218 | "I'm using is problematic,"
1219 | "as the distance between the"
1220 | "lines is noticably larger, and"
1221 | "sometimes gaps may appear between"
1222 | "the images. There might be a"
1223 | "better way to do it.")
1224 | do (progn
1225 | (goto-char (line-beginning-position))
1226 | (when (cl-getf (text-properties-at (point)) 'display)
1227 | (goto-char (line-end-position))
1228 | (insert " " (propertize
1229 | segment
1230 | 'face
1231 | '(:slant italic
1232 | :inherit (variable-pitch
1233 | font-lock-comment-face)))))
1234 | (forward-line)))
1235 | (goto-char (point-max))
1236 | (add-text-properties
1237 | start (point)
1238 | (list 'point-entered
1239 | (lambda (old new)
1240 | (when (cl-getf (text-properties-at (point)) 'display)
1241 | (funcall 'mb-kick-cursor old new))))))
1242 | (insert "\n"))))
1243 |
1244 | (mb-subsection "You can also crop images, or add a number of effects"
1245 | (insert "\n")
1246 | (insert-image `(image :type jpeg
1247 | :file ,mb-expamle-image)
1248 | "[you should be seeing an image]"
1249 | nil '(60 25 100 150))
1250 | (insert " ")
1251 | (insert-image `(image :type jpeg
1252 | :file ,mb-expamle-image
1253 | :conversion disabled)
1254 | "[you should be seeing an image]"
1255 | nil '(60 25 100 150))
1256 | (insert "\n"))
1257 | (mb-subsection "Images and text"
1258 | (insert "\n")
1259 | (let* (( width 50)
1260 | ( face-spec '(:height 1.5 :inherit variable-pitch))
1261 | ( image-data
1262 | (format ""
1267 | width width)))
1268 | (insert (propertize "A centered " 'face face-spec)
1269 | (propertize " "
1270 | 'display `(image :ascent 65
1271 | :type svg
1272 | :data ,image-data))
1273 | (propertize " inline image"
1274 | 'face face-spec)
1275 | "\n\n")
1276 | (insert (propertize "An image " 'face face-spec)
1277 | (propertize " "
1278 | 'display `(image :ascent 90
1279 | :type svg
1280 | :data ,image-data))
1281 | (propertize " aligned to the bottom" 'face face-spec))))))
1282 |
1283 | (mb-section "SVG"
1284 | "More complex effects can be achieved through SVG"
1285 | (mb-subsection "Resizing an masking"
1286 | (insert "\n")
1287 | ;; The link probably won't work on winodws
1288 | (let ((data (format ""
1297 | mb-expamle-image)))
1298 | (insert-image `(image :type svg :data ,data)
1299 | ))
1300 | (insert "\n\n"))
1301 | (mb-subsection "Subjecting online images to multiplication and skewing"
1302 | (insert "\n")
1303 | (let ((data ""))
1311 | (insert-image `(image :type svg :data ,data)))))
1312 |
1313 | ;; -----------------------------------------------------------------------------
1314 |
1315 | ;; (mb-section "Widgets"
1316 | ;; (insert-button "Click me" 'action
1317 | ;; (lambda (event)
1318 | ;; (message "Button clicked"))))
1319 |
1320 | ;; -----------------------------------------------------------------------------
1321 |
1322 | ;; (mb-section "Colors"
1323 | ;; (mapc (lambda (color)
1324 | ;; (insert (propertize
1325 | ;; (concat (propertize " "
1326 | ;; 'display '(space :height (1)))
1327 | ;; (propertize "\n" 'line-height t))
1328 | ;; 'face `(:background ,color))))
1329 | ;; (apply 'es-color-mixer
1330 | ;; (append (list (face-attribute 'default :background))
1331 | ;; (make-list 8 nil)
1332 | ;; (list (face-attribute 'default :foreground))))))
1333 |
1334 | ;; -----------------------------------------------------------------------------
1335 |
1336 | (mb-section "Fonts"
1337 | "One reason people use monospace fonts, it because they are easy to align.
1338 | At least with some fonts (ex. DejaVu Sans Mono), one can also align text
1339 | of different sizes."
1340 | (let ((point-start (point)))
1341 | (insert "\n"
1342 | (mb-colorize-string-chars
1343 | (propertize "Consequic"
1344 | 'face `(:height 800
1345 | :foreground ,(face-attribute
1346 | 'default :background)
1347 | :family "DejaVu Sans Mono")))
1348 | "\n"
1349 | (mb-colorize-string-chars
1350 | (propertize "Concedo quid"
1351 | 'face `(:height 600
1352 | :foreground ,(face-attribute
1353 | 'default :background)
1354 | :family "DejaVu Sans Mono")))
1355 | "\n"
1356 | (mb-colorize-string-chars
1357 | (propertize "Concursio hoc novi"
1358 | 'face `(:height 400
1359 | :foreground ,(face-attribute
1360 | 'default :background)
1361 | :family "DejaVu Sans Mono")))
1362 | "\n"
1363 | (mb-colorize-string-chars
1364 | (propertize "Non interdictum ego potu"
1365 | 'face `(:height 300
1366 | :foreground ,(face-attribute
1367 | 'default :background)
1368 | :family "DejaVu Sans Mono")))
1369 | "\n"
1370 | (mb-colorize-string-chars
1371 | (propertize "Ille aperiri quam, expetitur, nos vi"
1372 | 'face `(:height 200
1373 | :foreground ,(face-attribute
1374 | 'default :background)
1375 | :weight bold :family "DejaVu Sans Mono")))
1376 | "\n"
1377 | (mb-colorize-string-chars
1378 | (propertize "Ferantur individua animo praeclaram detractis non invenerit, uberius nos"
1379 | 'face `(:height 100
1380 | :foreground ,(face-attribute
1381 | 'default :background)
1382 | :weight bold :family "DejaVu Sans Mono")))
1383 | "\n")))
1384 |
1385 | ;; -----------------------------------------------------------------------------
1386 |
1387 | (defun magic-buffer (&rest ignore)
1388 | (interactive)
1389 | (let ((buf (get-buffer-create "*magic-buffer*")))
1390 | (with-current-buffer buf
1391 | (let ((inhibit-read-only t))
1392 | (erase-buffer)
1393 | (delete-all-overlays)
1394 | (fundamental-mode)
1395 | (progn
1396 | (setq truncate-lines nil)
1397 | (setq word-wrap t)
1398 | (setq line-spacing 0)
1399 | (setq truncate-partial-width-windows nil)
1400 | (setq left-fringe-width 8
1401 | right-fringe-width 8))
1402 | (setq-local revert-buffer-function 'magic-buffer)
1403 | (insert (propertize "Magic buffer"
1404 | 'face 'info-title-2)
1405 | "\n")
1406 | (mb-comment "If you want to see the source, do `M-x find-function
1407 | magic-buffer'")
1408 | (insert "\n")
1409 | (cl-dolist (section (if mb--exclusive-section
1410 | (cl-remove-if-not
1411 | (apply-partially
1412 | '= mb--exclusive-section)
1413 | mb-sections
1414 | :key 'car)
1415 | (cl-sort (cl-copy-list mb-sections)
1416 | '< :key 'car)))
1417 | (cl-destructuring-bind (number name doc function) section
1418 | (insert "\n\n")
1419 | (insert (propertize
1420 | (format "%s. %s:\n" number name)
1421 | 'face 'info-title-3))
1422 | (if doc
1423 | (mb-insert-filled
1424 | (propertize
1425 | (format "%s\n\n" doc)
1426 | 'face '(:inherit (variable-pitch font-lock-comment-face))))
1427 | (insert "\n"))
1428 | (funcall function)
1429 | (goto-char (point-max))
1430 | (unless (zerop (current-column))
1431 | (insert "\n"))
1432 | (insert "\n"))))
1433 | (unless view-mode
1434 | (view-mode 1))
1435 | (goto-char (point-min)))
1436 | (switch-to-buffer buf)))
1437 |
1438 | (provide 'magic-buffer)
1439 |
1440 | ;; Local Variables:
1441 | ;; truncate-lines: nil
1442 | ;; eval: (orgstruct-mode 1)
1443 | ;; orgstruct-heading-prefix-regexp: "^;;; \\*+"
1444 | ;; End:
1445 |
1446 | ;;; magic-buffer.el ends here
1447 |
--------------------------------------------------------------------------------