;;****************************************************************************
;;FILE:               pjb-computer-paper.el
;;LANGUAGE:           emacs lisp
;;SYSTEM:             POSIX
;;USER-INTERFACE:     NONE
;;DESCRIPTION
;;    
;;    XXX
;;    
;;AUTHORS
;;    <PJB> Pascal Bourguignon <spam@thalassa.informatimago.com>
;;MODIFICATIONS
;;    2004-01-31 <PJB> Created.
;;BUGS
;;LEGAL
;;    GPL
;;    
;;    Copyright Pascal Bourguignon 2004 - 2004
;;    
;;    This program is free software; you can redistribute it and/or
;;    modify it under the terms of the GNU General Public License
;;    as published by the Free Software Foundation; either version
;;    2 of the License, or (at your option) any later version.
;;    
;;    This program is distributed in the hope that it will be
;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;    PURPOSE.  See the GNU General Public License for more details.
;;    
;;    You should have received a copy of the GNU General Public
;;    License along with this program; if not, write to the Free
;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;    Boston, MA 02111-1307 USA
;;****************************************************************************
(require 'pjb-cl)
;; (require 'make-overlay)


(defconst +computer-paper-colors+  '("azure" "PaleTurquoise" "LightCyan1"
                                     "LightBlue"  "LightCyan" "PowderBlue"))


(defun delete-all-overlays ()
  (interactive)
  (mapcar (lambda (item)  (if (listp item) 
                       (mapcar (function delete-overlay) item)
                       (delete-overlay item)))  (overlay-lists)))


(defun put-computer-paper-overlay (modulo block)
  (delete-all-overlays)
  (goto-char (point-min))
  (let ((backf (make-array
                (list (length +computer-paper-colors+))
                :initial-contents 
                (mapcar
                 (lambda (color)
                   (let* ((facesym (intern 
                                    (concatenate 'string color "-face")))
                          (face (make-face facesym)))
                     (copy-face 'default face)
                     (set-face-background face color)
                     face))
                 +computer-paper-colors+)))
        (line 0))
    (while (< (point) (point-max))
      (let ((extent (make-overlay (progn (beginning-of-line) (point))
                                  (progn (forward-line block)
                                         (beginning-of-line) (point)))))
        (overlay-put extent 'evaporate t)
        (overlay-put extent 'face (aref backf (mod line modulo)))
        (incf line) ))))


(defun computer-paper ()
  (interactive)
  (let (modulo block)
    (cond
     ((integerp current-prefix-arg)
      (setf modulo (min current-prefix-arg (length +computer-paper-colors+))
            block  1))
     ((null     current-prefix-arg)
      (setf modulo (min 2 (length +computer-paper-colors+))
            block  1))
     ((consp    current-prefix-arg)
      (setf modulo (min (read-minibuffer "Modulo: " "2")
                        (length +computer-paper-colors+))
            block  (read-minibuffer "Block: " "1")))
     (t (error "Invalid prefix %S" current-prefix-arg)))
    (assert (<= 1 block))
    (assert (and (<= 2 modulo) (<= modulo (length +computer-paper-colors+))))
    (put-computer-paper-overlay modulo block)))
  

;;;; pjb-computer-paper.el            --                     --          ;;;;