fringe matrix editor.

matrix.el

;;; matrix.el -*- coding: utf-8-emacs -*-
;; Copyright (C) 2022 fubuki

;; Author: fubuki@frill.org
;; Version: @(#)$Revision: 1.11 $$Name:  $
;; Keywords: 

;; 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 3 of the License.

;; 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; fringe matrix editor.

;;; Installation:

;; (require 'matrix)

;;; Change Log:

;;; Code:
(defvar matrix-stones        '((0 . 9633) (1 . 9632)))
(defvar matrix-define-symbol 'bookmark-fringe-mark)

(make-local-variable (defvar matrix-ov     nil))
(defvar matrix-lf (propertize "\n" 'rear-nonsticky t 'read-only t 'cursor-intangible t))

(defvar matrix-width  8)
(defvar matrix-height 8)

(define-inline matrix-white ()
  (matrix-get-colour 0))

(define-inline matrix-black ()
  (matrix-get-colour 1))

(define-inline matrix-get-colour (colour)
  (cdr (assq colour matrix-stones)))

(defun matrix-number-string (num &optional width)
  "NUM を対応したキャラクタで並べた WIDTH 桁の二値表現文字列にする.
WIDTH の省略値は `matrix-width'."
  (let ((w (or width matrix-width)))
    (matrix--number-string num (/ (expt 2 w) 2))))

(defun matrix--number-string (num width)
  (if (zerop width)
      ""
    (concat
     (if (zerop (logand num width))
         (string (matrix-white))
       (string (matrix-black)))
     (matrix--number-string num (/ width 2)))))

(defun matrix-string-number (str)
  "ビット表現文字列を数値にする."
  (if (equal "" str)
      0
    (+ (if (equal (string-to-char str) (matrix-black))
           (expt 2 (1- (length str)))
         0)
       (matrix-string-number (substring str 1)))))

(defun matrix-region-number (beg end)
  (matrix-string-number (buffer-substring beg end)))

(defun matrix-init ()
  (dotimes (i matrix-height)
    (insert (matrix-number-string 0 matrix-width) matrix-lf))
  (matrix-fringe-update))

(defun matrix-erase-init ()
  (interactive)
  (let ((inhibit-read-only t))
    (erase-buffer)
    (matrix-init)
    (goto-char (point-min))))

(defun matrix-fringe-init ()
  (setq matrix-ov (make-overlay 1 1))
  (overlay-put matrix-ov
               'before-string
               (propertize
                "x" 'display
                '(left-fringe matrix-fringe warning)))
  (matrix-fringe-update))

(defun matrix-fringe-update ()
  (define-fringe-bitmap 'matrix-fringe (matrix-buffer-value))
  (set-window-buffer nil (current-buffer)))

(defun matrix-invert-line ()
  (interactive)
  (let ((inhibit-read-only t)
        (tmp
         (matrix-region-number (line-beginning-position) (line-end-position))))
    (save-excursion
      (delete-region (line-beginning-position) (line-end-position))
      (insert (matrix-number-string (logxor tmp 255)))
      (matrix-fringe-update))))

(defun matrix-invert-all ()
  (interactive)
    (save-excursion
      (goto-char (point-min))
      (dotimes (i matrix-height)
        (matrix-invert-line)
        (forward-line))))

(defun matrix-invert (prefix)
  (interactive "p")
  (dotimes (i prefix)
    (if (eq 10 (char-after)) (forward-char))
    (cond
     ((eobp)
      nil)
     ((equal (string (matrix-white)) (string (char-after)))
      (delete-char 1)
      (insert (string (matrix-black))))
     (t
      (delete-char 1)
      (insert (string (matrix-white))))))
  (matrix-fringe-update))

(defun matrix-put (prefix)
  (interactive "p")
  (dotimes (i prefix)
    (if (eolp)
        (forward-char)
      (delete-char 1)
      (insert (string (matrix-black)))))
  (matrix-fringe-update))

(defun matrix-backspace (prefix)
  (interactive "p")
  (dotimes (i prefix)
    (backward-char)
    (delete-char 1)
    (insert (string (matrix-white)))
    (backward-char))
  (matrix-fringe-update))

(defun matrix-delete (prefix)
  (interactive "p")
  (dotimes (i prefix)
    (delete-char 1)
    (insert (string (matrix-white)))
    (backward-char))
  (matrix-fringe-update))

(defun matrix-delete-foraward (prefix)
  (interactive "p")
  (dotimes (i prefix)
    (if (eq 10 (char-after)) (forward-char))
    (delete-char 1)
    (insert (string (matrix-white))))
  (matrix-fringe-update))

(defun matrix-define-and-quit ()
  (interactive)
  (matrix-define)
  (quit-window))

(defun matrix-undo (&optional arg)
  (interactive "*P")
  (undo arg)
  (matrix-fringe-update))

(defun matrix-buffer-value ()
  "バッファをビットマップ表現の並びとしてベクターにして返す."
  (let (result)
    (save-excursion
      (goto-char (point-min))
      (dotimes (i matrix-height (vconcat (reverse result)))
        (setq result
              (cons
               (matrix-region-number
                (line-beginning-position)
                (line-end-position))
               result))
        (forward-line)))))

(defun matrix-define ()
  "マトリクスワークバッファの内容をフリンジにセット."
  (interactive)
  (let ((result (matrix-buffer-value)))
    (and matrix-define-symbol
         (define-fringe-bitmap matrix-define-symbol result))
    (matrix-kill-new result)))

(defvar matrix-octstring nil)

(defun matrix-octstring (seq)
  (concat
   "\""
   (mapconcat #'(lambda (n) (format "%c%o" ?\\ n)) seq)
   "\""))

(defun matrix-kill-new (&optional bitmap)
  "BITMAP データをフリンジ設定する lisp 式にしキルリングにプッシュ.
BITMAP を省略するとマトリクスワークバッファの内容を対象にする."
  (interactive)
  (let ((result (or bitmap (matrix-buffer-value))))
    (message "Pushed definition to kill-ring.")
    (kill-new
     (format "(define-fringe-bitmap '%s %s)"
             matrix-define-symbol
             (if matrix-octstring
                 (matrix-octstring result)
               result)))))

;;;###autoload
(defun matrix (prefix)
  (interactive "P")
  (let ((buff "*matrix*")
        initial-frame-alist)
    (or prefix (and (get-buffer buff) (kill-buffer buff)))
    (setq buff (get-buffer-create buff))
    (switch-to-buffer buff)
    (unless prefix
      (matrix-init)
      (goto-char (point-min)))
    (matrix-mode)))

(defvar matrix-mode-map
  (let ((map (make-sparse-keymap)))
    (suppress-keymap map)
    (define-key map " "                'matrix-invert)
    (define-key map [remap delete-backward-char] 'matrix-backspace)
    (define-key map [remap delete-forward-char]  'matrix-delete-foraward)
    (define-key map [remap delete-char]          'matrix-delete)
    (define-key map "w"                'matrix-kill-new)
    (define-key map "\C-c\C-w"         'matrix-kill-new)
    (define-key map "\C-c\C-c"         'matrix-define-and-quit)
    (define-key map "\C-c\C-i"         'matrix-erase-init)
    (define-key map "\C-c\C-q"         'quit-window)
    (define-key map "f"                'forward-char)
    (define-key map "b"                'backward-char)
    (define-key map "n"                'next-line)
    (define-key map "p"                'previous-line)
    (define-key map "i"                'matrix-invert-line)
    (define-key map "I"                'matrix-invert-all)
    (define-key map "m"                'matrix-put)
    (define-key map "q"                'quit-window)
    (define-key map [remap undo]       'matrix-undo)
    (define-key map "\C-m"             'undefined)
    (define-key map "\C-j"             'undefined)
    (define-key map "\C-i"             'undefined)
    (define-key map "\C-k"             'undefined)
    (define-key map "\C-y"             'undefined)
    (define-key map "\M-y"             'undefined)
    map))

(define-derived-mode matrix-mode text-mode "Matrix"
  "Matrix Edit Mode"
  (matrix-fringe-init))

(provide 'matrix)
;; fin.