;;; juv-el --- juv-el -*- lexical-binding: t -*- ;; ;;; Commentary: ;; ;; Screenshots at https://dataswamp.org/~incal/juv-el ;; ;;; Code: (require 'cl-lib) (cl-pushnew "." load-path :test #'string=) (require 'comp) (require 'mosa-lisp) (require 'mosa-more) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq after-change-functions nil) (setq before-change-functions nil) (setq bidi-display-reordering nil) (setq bidi-inhibit-bpa t) (setq byte-optimize t) (setq cl--optimize-safety 0) (setq cl--optimize-speed 3) (setq native-comp-speed 3) (setq post-command-hook nil) (setq pre-command-hook nil) (setq truncate-lines t) (setq word-wrap nil) (menu-bar-mode -1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (when (& nil (display-graphic-p)) (set-face-attribute 'default nil :font "ocrb") (set-face-attribute 'default nil :height 100) (set-frame-parameter nil 'fullscreen 'fullboth) (set-frame-position nil 0 0) (set-frame-size nil 1920 1080 t) (set-scroll-bar-mode 'nil) (set-window-fringes nil 0 0) (set-window-margins nil 0 0) (set-window-scroll-bars nil 0 0 0) (setq blink-cursor-blinks 1) (setq line-spacing nil) (tool-bar-mode -1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-minor-mode juv-mode "The juv-el minor mode." :keymap (make-keymap) :after-hook (auto-composition-mode -1) (font-lock-mode -1) (setq-local cursor-type nil) (setq-local inhibit-modification-hooks t) (setq-local buffer-undo-list t)) (defvar juv-hash-chr (make-hash-table :test 'eq :size 1024)) (defvar juv-hash-face (make-hash-table :test 'eq :size 4096)) (defvar juv-hash-color (make-hash-table :test 'eq :size 4096)) (defconst juv-hex (vconcat (cl-loop for i from 0 below 256 collect (@f "%02x" i)))) (defmacro juv-color (r g b) `(let ((key (logior (ash ,r 16) (ash ,g 8) ,b))) (or (gethash key juv-hash-color) (puthash key (concat "#" (aref juv-hex ,r) (aref juv-hex ,g) (aref juv-hex ,b)) juv-hash-color)))) (defmacro juv-face (bg-r bg-g bg-b fg-r fg-g fg-b) `(let ((key (logior (ash ,bg-r 40) (ash ,bg-g 32) (ash ,bg-b 24) (ash ,fg-r 16) (ash ,fg-g 8) ,fg-b))) (or (gethash key juv-hash-face) (puthash key (list :background (juv-color ,bg-r ,bg-g ,bg-b) :foreground (juv-color ,fg-r ,fg-g ,fg-b)) juv-hash-face)))) (defun juv-aref-mod (v i) (cl-assert (vu v)) (cl-assert (ni i)) (let ((len (--- v))) (aref v (m (+ (m i len) len) len)))) (cl-defstruct juv-box (selected 0) (x 0) (y 0) (w 1) (h 1) (fun #'logxor) (data nil) (boxes nil) (v-ch nil) (v-bg-r nil) (v-bg-g nil) (v-bg-b nil) (v-fg-r nil) (v-fg-g nil) (v-fg-b nil) (v-bg0-r nil) (v-bg0-g nil) (v-bg0-b nil) (v-fg0-r nil) (v-fg0-g nil) (v-fg0-b nil) (fg-r 254) (fg-g 253) (fg-b 252) (bg-r 44) (bg-g 144) (bg-b 254) (border-fg-r 48) (border-fg-g 148) (border-fg-b 254)) (defun juv-hash-chr-init () (puthash ?A [0 0 1 1 1 1 0 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 1 1 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0] juv-hash-chr) (puthash ?B [0 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 1 1 0 0 0 1 0 0 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 1 1 0 0 0 1 0 0 1 1 1 1 1 1 0 0 1 1 1 1 1 0 0] juv-hash-chr) (puthash ?C [0 0 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 0 0] juv-hash-chr)) (puthash ?D [0 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 1 1 1 1 0 0 1 1 1 1 1 0 0 ] juv-hash-chr) (puthash ?D [ 0 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 1 1 0 0 0 0 0 0 1 1 1 1 1 0 0 0 1 1 1 1 1 0 0 0 1 1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 1 1 1 1 1 0 0 ] juv-hash-chr) (defun juv-draw-char (b chr x y &optional sw sh) (cl-assert (juv-box-p b)) (cl-assert (characterp chr)) (cl-assert (& (ni x) (<= 0 x))) (cl-assert (& (ni y) (<= 0 y))) (or (& (ni sw) (<= 0 sw)) (setf sw 1)) (or (& (ni sh) (<= 0 sh)) (setf sh 1)) (cl-loop with side = 8 for c across-ref (gethash chr juv-hash-chr) for i from 0 for row = (/ i side) for col = (m i side) for y-beg = (* (+ y (* row (juv-box-w b))) sh) for x-beg = (* (+ x col) sw) do (when (< 0 c) (cl-loop for src-row from 0 below sh for beg = (+ y-beg x-beg (* src-row (juv-box-w b))) for end = (+ beg sw) do (cl-loop for v-bg-i from beg below end do (aset (juv-box-v-bg0-r b) v-bg-i 244) (aset (juv-box-v-bg0-g b) v-bg-i 233) (aset (juv-box-v-bg0-b b) v-bg-i 222) ))))) (defun juv-walk-E (b) (cl-assert (juv-box-p b)) (++ (juv-box-x b))) (defun juv-walk-S (b) (cl-assert (juv-box-p b)) (++ (juv-box-y b))) (defun juv-walk-W (b) (cl-assert (juv-box-p b)) (-- (juv-box-x b))) (defun juv-walk-N (b) (cl-assert (juv-box-p b)) (-- (juv-box-y b))) (defun juv-push-E (b) (cl-assert (juv-box-p b)) (juv-resize b (+ (juv-box-w b) 1) (+ (juv-box-h b) 0))) (defun juv-push-S (b) (cl-assert (juv-box-p b)) (juv-resize b (+ (juv-box-w b) 0) (+ (juv-box-h b) 1))) (defun juv-fall-W (b) (cl-assert (juv-box-p b)) (juv-resize b (+ (juv-box-w b) -1) (+ (juv-box-h b) 0))) (defun juv-fall-N (b) (cl-assert (juv-box-p b)) (juv-resize b (+ (juv-box-w b) 0) (+ (juv-box-h b) -1))) (defun juv-draw (b) (cl-assert (juv-box-p b)) (let ((inhibit-modification-hooks t) (inhibit-read-only t) (inhibit-redisplay t)) (cl-loop with fancy-border = nil initially (fillarray (juv-box-v-ch b) 32) (fillarray (juv-box-v-fg0-r b) 0) (fillarray (juv-box-v-fg0-g b) 0) (fillarray (juv-box-v-fg0-b b) 0) (cl-replace (juv-box-v-bg0-r b) (juv-box-v-bg-r b)) (cl-replace (juv-box-v-bg0-g b) (juv-box-v-bg-g b)) (cl-replace (juv-box-v-bg0-b b) (juv-box-v-bg-b b)) for B across-ref (juv-box-boxes b) do (cl-loop with x-beg = (max 0 (juv-box-x B)) with y-beg = (max 0 (juv-box-y B)) with x-end = (min (+ (juv-box-x B) (juv-box-w B)) (juv-box-w b)) with y-end = (min (+ (juv-box-y B) (juv-box-h B)) (juv-box-h b)) with adv = 127 with adv-fg = 244 with ac = (- 255 adv) with ac-fg = (- 255 adv-fg) for r from y-beg below y-end for rb = (* r (juv-box-w b)) for ri from 0 for rB = (* ri (juv-box-w B)) for N = (& (z ri) (<= 0 (juv-box-y B))) for S = (= 1 (- (juv-box-h B) ri)) do (cl-loop for c from x-beg below x-end for ci from 0 for i from (+ x-beg rb) for li from rB for E = (= 1 (- (juv-box-w B) ci)) for W = (z ci) for border = (cond (fancy-border (or (& N W 9581) (& N E 9582) (& S W 9584) (& S E 9583) (& (or N S) (if (= (aref (juv-box-v-ch b) i) 9474) 9532 9472)) (& (or W E) (if (= (aref (juv-box-v-ch b) i) 9472) 9532 9474)))) ((or (& N W) (& N E) (& S W) (& S E)) ?+) ((or N S) (if (= (aref (juv-box-v-ch b) i) ?|) ?+ ?-)) ((or W E) (if (= (aref (juv-box-v-ch b) i) ?-) ?+ ?|))) do (if border (progn (aset (juv-box-v-ch b) i border) (aset (juv-box-v-fg0-r b) i (juv-box-border-fg-r B)) (aset (juv-box-v-fg0-g b) i (juv-box-border-fg-g B)) (aset (juv-box-v-fg0-b b) i (juv-box-border-fg-b B))) (aset (juv-box-v-ch b) i (juv-aref-mod (juv-box-data B) li)) (aset (juv-box-v-fg0-r b) i (ash (+ (* adv-fg (aref (juv-box-v-fg0-r b) i)) (* ac-fg (aref (juv-box-v-fg-r B) li))) -8)) (aset (juv-box-v-fg0-g b) i (ash (+ (* adv-fg (aref (juv-box-v-fg0-g b) i)) (* ac-fg (aref (juv-box-v-fg-g B) li))) -8)) (aset (juv-box-v-fg0-b b) i (ash (+ (* adv-fg (aref (juv-box-v-fg0-b b) i)) (* ac-fg (aref (juv-box-v-fg-b B) li))) -8)) (aset (juv-box-v-bg0-r b) i (ash (+ (* adv (aref (juv-box-v-bg0-r b) i)) (* ac (aref (juv-box-v-bg-r B) li))) -8)) (aset (juv-box-v-bg0-g b) i (ash (+ (* adv (aref (juv-box-v-bg0-g b) i)) (* ac (aref (juv-box-v-bg-g B) li))) -8)) (aset (juv-box-v-bg0-b b) i (ash (+ (* adv (aref (juv-box-v-bg0-b b) i)) (* ac (aref (juv-box-v-bg-b B) li))) -8)) ))) finally (juv-draw-char b ?A (+ (juv-box-x b) (* 0 8)) (+ (juv-box-y b) (* 0 8)) 1 1) (juv-draw-char b ?B (+ (juv-box-x b) (* 1 8)) (+ (juv-box-y b) (* 1 8)) 2 2) (juv-draw-char b ?C (+ (juv-box-x b) (* 2 8)) (+ (juv-box-y b) (* 2 8)) 3 3) (juv-draw-char b ?D (+ (juv-box-x b) (* 3 8)) (+ (juv-box-y b) (* 3 8)) 4 4) (juv-draw-char b ?E (+ (juv-box-x b) (* 4 8)) (+ (juv-box-y b) (* 4 8)) 5 5) (cl-loop with data = (juv-box-v-ch b) for bg-r across-ref (juv-box-v-bg0-r b) for bg-g across-ref (juv-box-v-bg0-g b) for bg-b across-ref (juv-box-v-bg0-b b) for fg-r across-ref (juv-box-v-fg0-r b) for fg-g across-ref (juv-box-v-fg0-g b) for fg-b across-ref (juv-box-v-fg0-b b) for i from 0 do (put-text-property i (1+ i) 'face (juv-face bg-r bg-g bg-b fg-r fg-g fg-b) data) finally (cl-loop initially (erase-buffer) (@i data) for y from (1- (juv-box-h b)) above 0 do (goto-char (1+ (* y (juv-box-w b)))) (@i 10) finally (let ((inhibit-redisplay nil)) (redisplay))))))) (defun juv-rows () (1- (window-size ))) (defun juv-cols () (1- (window-size nil t ))) (defun juv-resize (b w h) (cl-assert (juv-box-p b)) (cl-assert (ni w)) (cl-assert (ni h)) (setf (juv-box-w b) w) (setf (juv-box-h b) h) (let* ((len (* (juv-box-w b) (juv-box-h b)))) (setf (juv-box-v-ch b) (make-string len 32)) (setf (juv-box-v-bg-r b) (make-string len 0)) (setf (juv-box-v-bg-g b) (make-string len 0)) (setf (juv-box-v-bg-b b) (make-string len 0)) (setf (juv-box-v-bg0-r b) (make-string len 0)) (setf (juv-box-v-bg0-g b) (make-string len 0)) (setf (juv-box-v-bg0-b b) (make-string len 0)) (setf (juv-box-v-fg-r b) (make-string len 0)) (setf (juv-box-v-fg-g b) (make-string len 0)) (setf (juv-box-v-fg-b b) (make-string len 0)) (setf (juv-box-v-fg0-r b) (make-string len 0)) (setf (juv-box-v-fg0-g b) (make-string len 0)) (setf (juv-box-v-fg0-b b) (make-string len 0)) (juv-draw-gen-bg b) (mapc (L (B) (juv-resize B (+ (ash (juv-box-w b) -2) 3) (+ (ash (juv-box-h b) -2) 2))) (juv-box-boxes b)))) (defun juv-draw-gen-bg (b) (cl-assert (juv-box-p b)) (cl-loop with max-dim = (max 1 (funcall (juv-box-fun b) (juv-box-w b) (juv-box-h b))) for bg-r across-ref (juv-box-v-bg-r b) for bg-g across-ref (juv-box-v-bg-g b) for bg-b across-ref (juv-box-v-bg-b b) for i from 0 for x = (m i (juv-box-w b)) for y = (/ i (juv-box-w b)) for current = (min (funcall (juv-box-fun b) x y) max-dim) for part = (/ (ash current 8) max-dim) do (setf bg-r (ash (* (juv-box-bg-r b) part) -8)) (setf bg-g (ash (* (juv-box-bg-g b) part) -8)) (setf bg-b (ash (* (juv-box-bg-b b) part) -8)) finally (mapc (L (B) (juv-draw-gen-bg B)) (juv-box-boxes b)))) (defun juv-do (b f) (cl-assert (juv-box-p b)) (cl-assert (functionp f)) (funcall f (juv-aref-mod (juv-box-boxes b) (juv-box-selected b))) (juv-draw b)) (defun juv-next (b) (cl-assert (juv-box-p b)) (++ (juv-box-selected b))) (defun juv-prev (b) (cl-assert (juv-box-p b)) (-- (juv-box-selected b))) (defun juv-draw-with-stats (b) (cl-assert (juv-box-p b)) (let ((beg (luki-ticks)) (mem (juv-get-mem))) (juv-draw b) ($ (@f " 𑅀 [w×h = %d×%d] [%d chars] [%d ms] [cons +%d]" (juv-box-w b) (juv-box-h b) (- (point-max) (point-min)) (/ (* 1000 (- (luki-ticks) beg)) (luki-hz)) (- (juv-get-mem) mem))))) (defun juv-keys (b) (cl-assert (juv-box-p b)) ;; select (keymap-set juv-mode-map "TAB" (L () (juv-next b))) (keymap-set juv-mode-map "" (L () (juv-next b))) ;; move (keymap-set juv-mode-map "i" (L () (juv-do b #'juv-walk-N))) (keymap-set juv-mode-map "k" (L () (juv-do b #'juv-walk-S))) (keymap-set juv-mode-map "j" (L () (juv-do b #'juv-walk-W))) (keymap-set juv-mode-map "l" (L () (juv-do b #'juv-walk-E))) ;; resize (keymap-set juv-mode-map "I" (L () (juv-do b #'juv-fall-N))) (keymap-set juv-mode-map "K" (L () (juv-do b #'juv-push-S))) (keymap-set juv-mode-map "J" (L () (juv-do b #'juv-fall-W))) (keymap-set juv-mode-map "L" (L () (juv-do b #'juv-push-E))) ;; redraw (keymap-set juv-mode-map "R" (L () (juv-resize b (juv-cols) (juv-rows)) (juv-draw-with-stats b))) (keymap-set juv-mode-map "r" (L () (juv-draw-with-stats b))) ;; bury (keymap-set juv-mode-map "q" (L () (bury-buffer))) (keymap-set juv-mode-map "w" (L () (bury-buffer)))) (defun juv-get-mem () (+ cons-cells-consed floats-consed intervals-consed string-chars-consed strings-consed symbols-consed vector-cells-consed)) (defun juv-init (b) (cl-assert (juv-box-p b)) (juv-hash-chr-init) (cl-loop with funs = (vector #'logxor #'logior #'logand (L (a b) (+ a b 1)) (L (a b) (or (& (< 0 a) (/ b a)) b)) (L (a b) (or (& (< 0 b) (/ a b)) a)) (L (a b) (or (& (< 0 a) (m b a)) b)) (L (a b) (or (& (< 0 b) (m a b)) a))) with red = [ 2 252 2 246 2 246 2 238 ] with green = [ 1 1 252 246 1 1 246 238 ] with blue = [ 8 8 8 8 252 246 246 238 ] with data = [ 106 117 118 45 101 108 32 32 ] with boxes = (vector nil nil nil nil nil nil nil nil ) for BS being the elements of-ref boxes using (index i) for fun = (aref funs i) for rd = (aref red i) for grn = (aref green i) for blu = (aref blue i) do (setf BS (make-juv-box :fun fun :x (* i 5) :y (* i 4) :bg-r rd :bg-g grn :bg-b blu :data data)) finally (setf (juv-box-boxes b) boxes) (juv-resize b (juv-cols) (juv-rows)) (juv-keys b) (juv-draw b) finally return b)) (defun juv () (pop-buf (get-buffer-create "*juv-el*")) (delete-other-windows) (juv-mode) (juv-init (make-juv-box))) (provide 'juv) ;;; juv.el ends here