home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / utils / live-icon.el < prev    next >
Encoding:
Text File  |  1995-07-28  |  9.6 KB  |  324 lines
  1. ;; live-icon.el --- make frame icons represent the current frame contents
  2.  
  3. ;; Copyright (C) 1995 Rich Williams <rdw@hplb.hpl.hp.com>
  4. ;; Copyright (C) 1995 Jamie Zawinski <jwz@netscape.com>
  5.  
  6. ;; Authors: Rich Williams <rdw@hplb.hpl.hp.com>
  7. ;;          Jamie Zawinski <jwz@netscape.com>
  8.  
  9. ;; Version 1.2
  10.  
  11. ;; This file is part of XEmacs.
  12.  
  13. ;; XEmacs is free software; you can redistribute it and/or modify it
  14. ;; under the terms of the GNU General Public License as published by
  15. ;; the Free Software Foundation; either version 2, or (at your option)
  16. ;; any later version.
  17.  
  18. ;; XEmacs is distributed in the hope that it will be useful, but
  19. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21. ;; General Public License for more details.
  22.  
  23. ;; You should have received a copy of the GNU General Public License
  24. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  26.  
  27. ;; Generates little pixmaps representing the contents of your frames.
  28.  
  29. ;; #### This thing is somewhat of a mess and could stand some clean-up.
  30.  
  31. (defun live-icon-colour-name-from-face (face &optional bg-p)
  32.   "Do backward compatible things to faces and colours"
  33.   (if (and (boundp 'emacs-major-version)
  34.        (= emacs-major-version 19)
  35.        (>= emacs-minor-version 12))
  36.       (let ((colour (if bg-p
  37.             (face-background face 'all)
  38.               (face-foreground face 'all))))
  39.     (if (consp colour)
  40.         (setq colour (cdr (car colour))))
  41.     (if (color-instance-p colour)
  42.         (setq colour (color-instance-name colour)))
  43.     (if (specifierp colour)
  44.         (setq colour (color-name colour)))
  45.     (if colour
  46.         (let ((hack (format "%s" colour)))
  47.           (if (string-match "(?\\([^)]*\\))?" hack)
  48.           (substring hack (match-beginning 1) (match-end 1))
  49.         hack))))
  50.     (let ((p (if bg-p (face-background face) (face-foreground face))))
  51.       (and (pixelp p)
  52.        (pixel-name p)))))
  53.  
  54. (defun live-icon-alloc-colour (cmv colour)
  55.   "Allocate a colour and a char from the magic vector"
  56.   (let ((bob (assoc colour (aref cmv 0)))
  57.     (jim (aref cmv 2)))
  58.     (if bob
  59.     (cdr bob)
  60.       (aset cmv 0 (cons (cons colour jim) (aref cmv 0)))
  61.       (aset cmv 1 (1+ (aref cmv 1)))
  62.       (aset cmv 2 (1+ jim))
  63.       jim)))
  64.  
  65. (defun live-icon-from-frame (&optional frame)
  66.   "Calculates the live-icon XPM of FRAME."
  67.   (if (not frame)
  68.       (setq frame (selected-screen)))
  69.   (save-excursion
  70.     (select-screen frame)
  71.     (let* ((w (screen-width))
  72.        (h (screen-height))
  73.        (pix (make-vector h nil))
  74.        (ny 0)
  75.        (cmv (vector nil 0 ?A))
  76.        (d (live-icon-alloc-colour
  77.            cmv (pixel-name (face-background 'default))))
  78.        (m (live-icon-alloc-colour
  79.            cmv (pixel-name (face-background 'modeline))))
  80.        (x (live-icon-alloc-colour
  81.            cmv (pixel-name (face-foreground 'default))))
  82.        y)
  83.       (let ((loop 0))
  84.     (while (< loop h)
  85.       (aset pix loop (make-string w d))
  86.       (setq loop (1+ loop))))
  87.       (mapcar #'(lambda (win)
  88.               (save-excursion
  89.             (save-window-excursion
  90.               (select-window win)
  91.               (save-restriction
  92.                 (setq y ny
  93.                   ny (+ ny (1- (window-height))))
  94.                 (aset pix (- ny 2) (make-string w m))
  95.                 (widen)
  96.                 (if (> (window-end) (window-start))
  97.                 (narrow-to-region (window-start)
  98.                           (1- (window-end))))
  99.                 (goto-char (point-min))
  100.                 (while (and (not (eobp))
  101.                     (< y (1- ny)))
  102.                   (while (and (not (eolp))
  103.                       (< (current-column) w))
  104.                 (if (> (char-after (point)) 32)
  105.                     (let* ((ex (extent-at (point) (current-buffer) 'face))
  106.                        (f (if ex (extent-face ex)))
  107.                        (z (if f (live-icon-colour-name-from-face f)))
  108.                        (c (if z (live-icon-alloc-colour cmv z) x)))
  109.                       (aset (aref pix y) (current-column) c)))
  110.                 (forward-char 1))
  111.                   (setq y (1+ y))
  112.                   (forward-line 1))))))
  113.           (sort (if (fboundp 'window-list)
  114.             (window-list)
  115.               (let* ((w (screen-root-window))
  116.                  (ws nil))
  117.             (while (not (memq (setq w (next-window w)) ws))
  118.               (setq ws (cons w ws)))
  119.             ws))
  120.             (if (fboundp 'window-pixel-edges)
  121.             #'(lambda (won woo)
  122.                 (< (nth 1 (window-pixel-edges won))
  123.                    (nth 1 (window-pixel-edges woo))))
  124.               #'(lambda (won woo)
  125.               (< (nth 1 (window-edges won))
  126.                  (nth 1 (window-edges woo)))))))
  127.       (concat "/* XPM */\nstatic char icon[] = {\n" 
  128.           (format "\"%d %d %d 1\",\n" w (* h 2) (aref cmv 1))
  129.           (mapconcat #'(lambda (colour-entry)
  130.                (format "\"%c c %s\"" 
  131.                    (cdr colour-entry) 
  132.                    (car colour-entry)))
  133.              (aref cmv 0)
  134.              ",\n")
  135.           ",\n"
  136.           (mapconcat #'(lambda (scan-line)
  137.                (concat "\"" scan-line "\"," "\n"
  138. ;;                   "\"" scan-line "\""
  139.                    "\"" (make-string w d) "\","
  140.                    ))
  141.              pix
  142.              ",\n")
  143.           "};\n"))))
  144.  
  145.  
  146. (defun live-icon-start-ppm-stuff (&optional frame)
  147.   "Start a live icon conversion going"
  148.   (interactive)
  149.   (if (not frame)
  150.       (setq frame (selected-screen)))
  151.   (let ((buf (get-buffer-create " *live-icon*")))
  152.     (message "live-icon...(backgrounding)")
  153.     (save-excursion
  154.       (set-buffer buf)
  155.       (erase-buffer))
  156.     (set-process-sentinel
  157.      (start-process-shell-command "live-icon"
  158.                   buf
  159.                   "xwd"
  160.                   "-id" (format "%s" (x-window-id frame)) "|"
  161.                   "xwdtopnm" "|" 
  162.                   "pnmscale" "-xysize" "64" "64" "|"
  163.                   "ppmquant" "256" "|"
  164.                   "ppmtoxpm")
  165.      #'(lambda (p s)
  166.      (message "live-icon...(munching)")
  167.      (save-excursion
  168.        (set-buffer " *live-icon*")
  169.        (goto-char (point-min))
  170.        (search-forward "/* XPM */")
  171.        (x-set-screen-icon-pixmap frame
  172.                     (make-pixmap
  173.                      (buffer-substring
  174.                       (match-beginning 0) (point-max)))))
  175.      (message "live-icon...... done"))))
  176.   nil)
  177.  
  178.  
  179. (defun live-icon-one-frame (&optional frame)
  180.   "Gives FRAME (defaulting to (selected-frame)) a live icon."
  181.   (interactive)
  182. ;  (message "Updating live icon...")
  183.   (if (not frame)
  184.       (setq frame (selected-screen)))
  185.   (x-set-screen-icon-pixmap frame (make-pixmap (live-icon-from-frame frame)))
  186. ;  (message "Updating live icon... done")
  187.   )
  188.  
  189. (defun live-icon-all-frames ()
  190.   "Gives all your frames live-icons."
  191.   (interactive)
  192.   (message "Updating live icons...")
  193.   (mapcar #'(lambda (fr)
  194.           (x-set-screen-icon-pixmap
  195.            fr (make-pixmap (live-icon-from-frame fr))))
  196.       (screen-list))
  197.   (message "Updating live icons... done"))
  198.  
  199. (add-hook 'unmap-screen-hook 'live-icon-one-frame)
  200. ;;(start-itimer "live-icon" 'live-icon-all-frames 120 120)
  201.  
  202.  
  203.  
  204. (defun live-icon-goto-position (x y)
  205.   (let (window edges)
  206.     (catch 'done
  207.       (walk-windows
  208.        #'(lambda (w)
  209.        (setq edges (window-edges w))
  210.        (if (and (>= x (nth 0 edges))
  211.             (<= x (nth 2 edges))
  212.             (>= y (nth 1 edges))
  213.             (<= y (nth 3 edges)))
  214.            (throw 'done (setq window w))))
  215.        nil t))
  216.     (if (not window)
  217.     nil
  218.       (select-window window)
  219.       (move-to-window-line (- y (nth 1 edges)))
  220.       (move-to-column (- x (nth 0 edges)))
  221.       )))
  222.  
  223. (defun live-icon-make-image (width height)
  224.   (let* ((text-aspect 1.5)
  225.      (xscale (/ (/ (* (screen-width)  1.0) width) text-aspect))
  226.      (yscale (/ (* (screen-height) 1.0) height))
  227.      (x 0)
  228.      (y 0)
  229.      (cmv (vector nil 0 ?A))
  230.      (default-fg (live-icon-alloc-colour
  231.               cmv (pixel-name (face-foreground 'default))))
  232.      (default-bg (live-icon-alloc-colour
  233.               cmv (pixel-name (face-background 'default))))
  234.      (modeline-bg (live-icon-alloc-colour
  235.                cmv (pixel-name (face-background 'modeline))))
  236.      (lines (make-vector height nil)))
  237.     ;;
  238.     ;; Put in the text.
  239.     ;;
  240.     (save-excursion
  241.       (save-window-excursion
  242.     (while (< y height)
  243.       (aset lines y (make-string width default-bg))
  244.       (setq x 0)
  245.       (while (< x width)
  246.         (let ((sx (floor (* x xscale)))
  247.           (sy (floor (* y yscale))))
  248.           (live-icon-goto-position sx sy)
  249.           (let* ((extent (extent-at (point) (current-buffer) 'face))
  250.              (face (if extent (extent-face extent)))
  251.              (name (if face (live-icon-colour-name-from-face
  252.                      face (<= (char-after (point)) 32))))
  253.              (color (if name
  254.                 (live-icon-alloc-colour cmv name)
  255.                   (if (<= (or (char-after (point)) 0) 32)
  256.                   default-bg default-fg))))
  257.         (aset (aref lines y) x color)))
  258.         (setq x (1+ x)))
  259.       (setq y (1+ y)))))
  260.     ;;
  261.     ;; Now put in the modelines.
  262.     ;;
  263.     (let (sx sy)
  264.       (walk-windows
  265.        #'(lambda (w)
  266.        (let ((edges (window-edges w)))
  267.          (setq x (nth 0 edges)
  268.            y (nth 3 edges)
  269.            sx (floor (/ x xscale))
  270.            sy (floor (/ y yscale)))
  271.          (while (and (< x (1- (nth 2 edges)))
  272.              (< sx (length (aref lines 0))))
  273.            (aset (aref lines sy) sx modeline-bg)
  274.            (if (> sy 0)
  275.            (aset (aref lines (1- sy)) sx modeline-bg))
  276.            (setq x (1+ x)
  277.              sx (floor (/ x xscale))))
  278.          (if (>= sx (length (aref lines 0)))
  279.          (setq sx (1- sx)))
  280.          (while (>= y (nth 1 edges))
  281.            (aset (aref lines sy) sx modeline-bg)
  282.            (setq y (1- y)
  283.              sy (floor (/ y yscale))))))
  284.        nil nil))
  285.     ;;
  286.     ;; Now put in the top and left edges
  287.     ;;
  288.     (setq x 0)
  289.     (while (< x width)
  290.       (aset (aref lines 0) x modeline-bg)
  291.       (setq x (1+ x)))
  292.     (setq y 0)
  293.     (while (< y height)
  294.       (aset (aref lines y) 0 modeline-bg)
  295.       (setq y (1+ y)))
  296.     ;;
  297.     ;; Now make the XPM
  298.     ;;
  299.     (concat "/* XPM */\nstatic char icon[] = {\n" 
  300.         (format "\"%d %d %d 1\",\n"
  301.             width
  302. ;;            (* height 2)
  303.             height
  304.             (aref cmv 1))
  305.         (mapconcat #'(lambda (colour-entry)
  306.                (format "\"%c c %s\""
  307.                    (cdr colour-entry) 
  308.                    (car colour-entry)))
  309.                (aref cmv 0)
  310.                ",\n")
  311.         ",\n"
  312.         (mapconcat #'(lambda (scan-line)
  313.                (concat "\"" scan-line "\"," "\n"
  314. ;;                   "\"" scan-line "\""
  315. ;;                   "\"" (make-string width default-bg)
  316. ;;                   "\","
  317.                    ))
  318.                lines
  319.                ",\n")
  320.         "};\n")))
  321.  
  322. (provide 'live-icon)
  323. ;;; live-icon.el ends here
  324.