;;; bitmap.el -- Emacs natively supports in-line monochrome rectangles on graphic displays
;;; Copyright (c) 2017 Devon Sean McCullough
;;; Licensed under the GNU GPL

;;; TO DO:
;; Support `put-image' overlays, e.g., an `image-before' function.
;; bitblt (alu width-height from-image-x-y to-image-x-y) or similar.
;; advise or patch `create-image' to support a constant initial pixel.
;; Emacs native support for, e.g., xbm24 RGB or xbm32 RGBA color pixels.

;;;	Example
;;		M-x eval-buffer Ret
;;		M-x blarg Ret
;;	**  *           
;;	* * *           
;;	**  *  ** **  **
;;	* * * * * *  * *
;;	**  *  ** *   **
;;	               *
;;	             **  <-- this space will appear as a bitmap image on graphic displays
;;	
;;	(let* ((image (xbm-string-to-image (documentation 'blarg)))
;;	       (width (image-width image))
;;	       (height (image-height image))
;;	       (standard-output (current-buffer)))
;;	  (dotimes (j height)
;;	    (terpri)
;;	    (dotimes (i width)
;;	      (princ (aref ["  " "[]"]
;;			   (image-pixel image i j))))))
;;	
;;	[][]    []                      
;;	[]  []  []                      
;;	[][]    []    [][]  [][]    [][]
;;	[]  []  []  []  []  []    []  []
;;	[][]    []    [][]  []      [][]
;;	                              []
;;	                          [][]  

(defun image-after (&optional pos)
  "Return image in current buffer at position POS.
POS is an integer or a marker and defaults to point.
If POS is out of range or has no image, the value is nil."
  ;; BUGS:  Not tested with `put-image' overlays.
  (let* ((pos (or pos (point)))
	 (display (and (<= (point-min) pos)
		       (< pos (point-max))
		       (get-text-property pos 'display))))
    (and (eq 'image (car display))
	 display)))

(defun image-width (image)
  (unless (eq 'image (car-safe image))
    (error "Not an image: %s" image))
  (getf (cdr image) ':width))

(defun image-height (image)
  (unless (eq 'image (car-safe image))
    (error "Not an image: %s" image))
  (getf (cdr image) ':height))

(defun image-pixel (image i j &optional value)
  "Access IMAGE pixel at column I, row J where zero origin is upper left pixel.
Optional VALUE to set rather than get.  Foreground is 1, background is 0."
  ;; bool-vector data octets scrambled in window-system ns
  ;;   workaround:
  ;;	width* rounded up to multiple of 8
  ;;	i* low three bits count backwards
  ;; TO DO: Discover data layout in non-NeXTStep window systems.
  (let* ((image (or image
		    (image-after)
		    (error "No image after point.")))
	 (car (car-safe image))
	 (cdr (cdr-safe image))
	 (type (getf cdr ':type))
	 (data (getf cdr ':data))
	 (width (getf cdr ':width))
	 (height (getf cdr ':height)))
    (unless (eq 'image car)
      (error "Not an image: %s" image))
    (unless (eq 'xbm type)
      (error "Unsupported image type %s"
	     type))
    (unless (and (bool-vector-p data)
		 (integerp width)
		 (integerp height)
		 (<= (* width height)
		     (length data)))
      (error "Bad image: %s"
	     image))
    (unless (and (integerp i) (<= 0 i) (< i width)
		 (integerp j) (<= 0 j) (< j height))
      (error "args-out-of-range %s %s %s"
	     image i j))
    (let ((width* (logand -8 (+ 7 width)))
	  (i* (logxor 7 i)))
      (cond (value
	     (setf (aref data (+ i* (* width* j)))
		   (not (zerop value)))
	     value)
	    (t (if (aref data (+ i* (* width* j)))
		   1
		 0))))))

(defun xbm-file-to-image (file)
  "Parse xbm image FILE."
  (xbm-string-to-image (with-temp-buffer
			 (insert-file-contents-literally file)
			 (buffer-string))))

(defun xbm-string-to-image (xbm)
  "Parse XBM image string."
  (interactive (read-string "XBM image string: "))
  (with-temp-buffer
    (save-excursion
      (insert xbm))
    (let* ((width (save-excursion
		    (and (search-forward-regexp "#.*width.*\\<\\([0-9]+\\)" nil t)
			 (string-to-number (match-string 1)))))
	   (height (save-excursion
		     (and (search-forward-regexp "#.*height.*\\<\\([0-9]+\\)" nil t)
			  (string-to-number (match-string 1)))))
	   (octets (loop
		    while (search-forward-regexp "0x\\([0-9A-Fa-f]\\{2\\}\\)" nil t)
		    collect (string-to-number (match-string 1) 16))))
      (unless (and width
		   height
		   (= (ceiling (* width height) 8)
		      (length octets)))
	(error "Bad xbm string: %s"
	       xbm))
      (let* ((pixels (mapcan (lambda (octet)
			       (loop
				for i below 8
				collect (logand 1 (lsh octet (- i)))))
			     octets))
	     (width* (logand -8 (+ 7 width)))
	     (data (make-bool-vector (* width* height) nil)))
	(dotimes (j height)
	  (dotimes (i width)
	    (let ((i* (logxor 7 i)))
	      (setf (aref data (+ i* (* width* j)))
		    (not (zerop (pop pixels)))))))
	(create-image data 'xbm t
		      :width width
		      :height height)))))

(defun rectangle-to-image (start end)
  "Return an xbm image of the region-rectangle with START, END corners."
  (interactive "r\nd")
  (let* ((rect (coerce (extract-rectangle start end) 'vector))
	 (width (apply #'max (mapcar #'length rect)))
	 (width* (logand -8 (+ 7 width)))
	 (height (length rect))
	 (data (make-bool-vector (* width* height) nil)))
    (dotimes (j height)
      (dotimes (i width)
	(let ((i* (logxor 7 i)))
	  (setf (aref data (+ i* (* width* j)))
		(/= ?\s (aref (aref rect j) i))))))
    (create-image data 'xbm t
		  :width width
		  :height height)))

(defun image-to-rectangle (&optional image fg-char bg-char)
  "Insert ascii art of optional IMAGE which defaults to image after point.
Optional FG-CHAR defaults to ?\* (asterisk) for non-zero pixels and
optional BG-CHAR defaults to ?\\s (space) for zero pixels."
  (interactive)
  (let* ((image (or image
		    (image-after)
		    (error "No image after point.")))
	 (car (car image))
	 (cdr (cdr image))
	 (type (getf cdr ':type))
	 (data (getf cdr ':data))
	 (width (getf cdr ':width))
	 (width* (logand -8 (+ 7 width)))
	 (height (getf cdr ':height))
	 (fg-char (or fg-char ?*))
	 (bg-char (or bg-char ?\s))
	 (standard-output (point-marker)))
    (unless (eq 'image car)
      (error "Not an image: %s" image))
    (unless (eq 'xbm type)
      (error "Unsupported image type %s"
	     type))
    (dotimes (j height)
      (terpri)
      (dotimes (i width)
	(let ((i* (logxor 7 i)))
	  (write-char (if (aref data (+ i* (* width* j)))
			  fg-char
			bg-char)))))))

(defun blarg (&optional image)
  "Draw ascii-art rectangle and `insert-image' of optional IMAGE
which defaults to the example at https://en.Wikipedia.org/wiki/X_BitMap

#define test_width 16
#define test_height 7
static char test_bits[] = { 0x13, 0x00, 0x15, 0x00, 0x93, 0xcd, 0x55, 0xa5, 0x93, 0xc5, 0x00, 0x80,0x00, 0x60 };"
  (interactive)
  (let ((image (or image
		   (xbm-string-to-image
		    (documentation 'blarg)))))
    (image-to-rectangle image)
    (insert-image image)))

;;; bitmap.el end