;;; -*- lexical-binding: t -*- (require 'color) (require 'eieio) (require 'bad-alpha) (require 'bad-box) (require 'bad-box-draw) (require 'bad-box-rotate) (require 'bad-caption) (require 'bad-cyclic) (require 'bad-demo) (require 'bad-draw) (require 'bad-elem) (require 'bad-game) (require 'bad-line) (require 'bad-move) (require 'bad-rotate) (require 'bad-size) (require 'bad-triangle) (require 'bad-write) (defclass studio (game) ((name :initform "studio") (pen :initarg :pen :type (or null symbol) :initform nil) (colors :initarg :colors :type list :initform nil) (col-r :initarg :col-r :type list :initform nil) (col-g :initarg :col-g :type list :initform nil) (col-b :initarg :col-b :type list :initform nil) (canvas :initarg :canvas :type (or null box) :initform nil) (elems :initarg :elems :type list :initform nil) (sel :initarg :sel :type (or null elem) :initform nil) ; selected element (ie :initarg :ie :type integer :initform 0) ; index element (pos-funs :initarg :pos-funs :type list :initform (list #'bad-origo #'bad-center)) (size-funs :initarg :size-funs :type list :initform (list #'bad-size-half #'bad-size-square #'bad-size-max #'bad-size-min)))) (cl-defmethod bad-init ((s studio)) (bad-alpha-set) (bad-rgb-list s) (with-slots (screen canvas elems sel help w h) s (setf help (caption :name "help" :text #5=(string-join #3=(list #2=(format "%s help " #1="[h]") "[a] add box " "[t] triangle " "[n] .... next" "[p] .... prev" "[s] box side " "[0] .. corner" "[1] .. border" "[8] alpha dec" "[9] ..... inc" "[g] .. ground" "[v] visible " "[V] delete " "[r] rotate " "[R] .... back" "[T] transpose" "[f] flip " "[F] .... back" "[;] position " "[d] size " "[D] .... full" "[Q] text-mode" "[q] quit " "move: [i] " " [j] [k] [l]" "size: " " [u] [I] [o]" " [J] [K] [L]")) :w #4=(length #2#) :h (length #3#) :text-draw #5# :text-alt (string-pad #1# #4# bad-nonsolid t))) (bad-update help) (with-slots ((hw w)) help (bad-pos help #1=(- w hw)) (setq canvas (box :name "canvas" :spc '(?\s ?.) :movable nil :transposable nil :w (1- #1#) :h h)) (bad-update canvas)) (with-slots (sub) screen (setf sub (list canvas help))) (bad-update screen) (setf elems (list canvas)) (setf sel (car elems)) (bad-init-keys s) (bad-setup s))) (cl-defmethod bad-update ((s studio)) (with-slots (screen) s (bad-update screen) (bad-draw-to-buf screen))) (cl-defmethod bad-run ((s studio)) (bad-init s) (bad-update s)) (cl-defmethod bad-init-keys ((s studio)) ;; (set-char-table-range (nth 1 bad-demo-mode-map) t #'ignore) ;; RGB (keymap-set bad-demo-mode-map "5" (lambda () (interactive) (bad-color-more s 'red))) (keymap-set bad-demo-mode-map "%" (lambda () (interactive) (bad-color-more s 'red t))) (keymap-set bad-demo-mode-map "6" (lambda () (interactive) (bad-color-more s 'green))) (keymap-set bad-demo-mode-map "^" (lambda () (interactive) (bad-color-more s 'green t))) (keymap-set bad-demo-mode-map "7" (lambda () (interactive) (bad-color-more s 'blue))) (keymap-set bad-demo-mode-map "&" (lambda () (interactive) (bad-color-more s 'blue t))) ;; alpha (keymap-set bad-demo-mode-map "9" (lambda () (interactive) (bad-alpha-more))) (keymap-set bad-demo-mode-map "8" (lambda () (interactive) (bad-alpha-less))) ;; cycle (keymap-set bad-demo-mode-map "p" (lambda () (interactive) (bad-prev s))) (keymap-set bad-demo-mode-map "n" (lambda () (interactive) (bad-next s))) ;; rotate (keymap-set bad-demo-mode-map "r" (lambda () (interactive) (bad-operate s #'bad-rotate))) (keymap-set bad-demo-mode-map "R" (lambda () (interactive) (bad-operate s #'bad-rotate-back))) (keymap-set bad-demo-mode-map "f" (lambda () (interactive) (bad-operate s #'bad-flip-x))) (keymap-set bad-demo-mode-map "F" (lambda () (interactive) (bad-operate s #'bad-flip-y))) (keymap-set bad-demo-mode-map "T" (lambda () (interactive) (bad-operate s #'bad-transpose))) ;; add (keymap-set bad-demo-mode-map "a" (lambda () (interactive) (bad-add-box s))) (keymap-set bad-demo-mode-map "P" (lambda () (interactive) (bad-add-line s))) (keymap-set bad-demo-mode-map "t" (lambda () (interactive) (bad-add-triangle s))) ;; color (keymap-set bad-demo-mode-map "c" (lambda () (interactive) (bad-random-color 'fg))) (keymap-set bad-demo-mode-map "C" (lambda () (interactive) (bad-random-color 'bg))) ;; box (keymap-set bad-demo-mode-map "0" (lambda () (interactive) (bad-set-corner s))) (keymap-set bad-demo-mode-map "1" (lambda () (interactive) (bad-set-border s))) (keymap-set bad-demo-mode-map "2" (lambda () (interactive) (bad-cycle-border s))) (keymap-set bad-demo-mode-map "s" (lambda () (interactive) (bad-set-side s))) (keymap-set bad-demo-mode-map "g" #1=(lambda () (interactive) (bad-set-ground s))) (keymap-set bad-demo-mode-map "b" #1#) ;; size (keymap-set bad-demo-mode-map "d" (lambda () (interactive) (bad-cycle-size s))) (keymap-set bad-demo-mode-map "D" (lambda () (interactive) (bad-operate s #'bad-size-max))) ;; row (keymap-set bad-demo-mode-map "I" (lambda () (interactive) (bad-operate s #'bad-add-row -1))) (keymap-set bad-demo-mode-map "K" (lambda () (interactive) (bad-operate s #'bad-add-row))) ;; col (keymap-set bad-demo-mode-map "u" (lambda () (interactive) (bad-operate s #'bad-add-col -1))) (keymap-set bad-demo-mode-map "o" (lambda () (interactive) (bad-operate s #'bad-add-col))) (keymap-set bad-demo-mode-map "J" (lambda () (interactive) (bad-operate s #'bad-add-col -1))) (keymap-set bad-demo-mode-map "L" (lambda () (interactive) (bad-operate s #'bad-add-col))) ;; pos (keymap-set bad-demo-mode-map ":" (lambda () (interactive) (bad-cycle-pos s))) (with-slots (canvas) s (keymap-set bad-demo-mode-map ";" (lambda () (interactive) (bad-operate s #'bad-pos-inside canvas)))) ;; move ;; [these don't work! no idea why] (keymap-set bad-demo-mode-map "" (lambda () (interactive) (bad-operate s #'bad-up))) (keymap-set bad-demo-mode-map "" (lambda () (interactive) (bad-operate s #'bad-down))) (keymap-set bad-demo-mode-map "" (lambda () (interactive) (bad-operate s #'bad-left))) (keymap-set bad-demo-mode-map "" (lambda () (interactive) (bad-operate s #'bad-right))) ;; [these works] (keymap-set bad-demo-mode-map "i" (lambda () (interactive) (bad-operate s #'bad-up))) (keymap-set bad-demo-mode-map "k" (lambda () (interactive) (bad-operate s #'bad-down))) (keymap-set bad-demo-mode-map "j" (lambda () (interactive) (bad-operate s #'bad-left))) (keymap-set bad-demo-mode-map "l" (lambda () (interactive) (bad-operate s #'bad-right))) ;; unsorted (keymap-set bad-demo-mode-map "h" (lambda () (interactive) (bad-help-toggle s))) (keymap-set bad-demo-mode-map "V" (lambda () (interactive) (bad-delem s))) (keymap-set bad-demo-mode-map "v" (lambda () (interactive) (bad-operate s #'bad-visible))) (keymap-set bad-demo-mode-map "Q" #'text-mode) (keymap-set bad-demo-mode-map "q" #'kill-emacs)) ;; ----------------------------------------------------------------------- (cl-defmethod bad-delem ((s studio)) ; delete element (with-slots (elems sel) s (with-slots (visible deleted) sel (when (and elems sel) (setf visible nil) (setf deleted t) (setf elems (remove sel elems)) (bad-next s)))) (bad-update s)) ;; ----------------------------------------------------------------------- (cl-defmethod bad-next ((s studio) &optional n) (or n (setq n 1)) (with-slots (elems sel ie) s (when elems (cl-loop do (setf sel (nth (mod (cl-incf ie n) (length elems)) elems)) until (and sel (slot-boundp sel 'name))) (with-slots (name) sel (message name))))) (cl-defmethod bad-prev ((s studio) &optional n) (or n (setq n 1)) (bad-next s (- n))) ;; ----------------------------------------------------------------------- (cl-defmethod bad-operate ((s studio) fun &rest args) (with-slots (sel) s (when (and sel (functionp fun)) (apply fun `(,sel ,@args)) (bad-update s)))) ;; ----------------------------------------------------------------------- (cl-defmethod bad-color-pen ((s studio)) (with-slots (pen sel canvas w x y) s (with-slots ((cx x) (cy y) (cw w)) canvas (when sel (with-slots ((ix x) (iy y) (iw w)) sel (put-text-property (max (point-min) #1=(+ -1 iy ix cx x (* (1- iy) w))) (min (point-max) #2=(+ 1 #1#)) 'face #3=pen) (message "draw: %d %d %s" #1# #2# #3#)))))) (cl-defmethod bad-color-next ((s studio)) (with-slots (pen colors sel) s (setf pen (car (setf colors (bad-list-shift colors)))) (message "pen: %s" pen))) ;; ----------------------------------------------------------------------- (cl-defmethod bad-add ((s studio) (e elem)) (with-slots (sel elems) s (when sel (let ((inner (bad-add sel e))) (push inner elems) (setq sel inner) (bad-update s))))) (cl-defmethod bad-add-box ((s studio)) (bad-add s (box))) (cl-defmethod bad-add-triangle ((s studio)) (bad-add s (triangle))) (cl-defmethod bad-add-line ((s studio)) (bad-add s (line))) ;; ----------------------------------------------------------------------- (cl-defmethod bad-set-ground ((s studio)) (let ((str (read-string (format "pattern? [%s] " #1="░") nil nil #1#))) (with-slots (sel) s (when (and sel (box-p sel)) (bad-clear sel (string-to-list str)) (bad-update s))))) (cl-defmethod bad-set-side ((s studio)) (let ((side (read-number "side? (1-4) ")) (str (read-string (format "pattern? [%s] " #1="━") nil nil #1#))) (with-slots (sel) s (when (and sel (box-p sel)) (bad-side sel side str) (bad-update s))))) (cl-defmethod bad-cycle-border ((s studio)) (with-slots (sel) s (when (and sel (box-p sel)) (bad-cycle-border sel) (bad-update s)))) (cl-defmethod bad-set-border ((s studio)) (with-slots (sel) s (when (and sel (box-p sel)) (let ((c (read-char "char? [light]"))) (if (= c 13) (bad-make-light sel) (bad-border sel c)) (bad-update s))))) ;; ----------------------------------------------------------------------- (cl-defmethod bad-rgb-list ((s studio)) (with-slots (col-r col-g col-b) s (cl-loop for c in (defined-colors-with-face-attributes) with rgb-list for rgb = (color-values c) for r = (nth 0 rgb) for g = (nth 1 rgb) for b = (nth 2 rgb) do (cl-pushnew (list r g b c) rgb-list :test #'equal) finally do (setf col-r (sort rgb-list :key #'car)) (setf col-g (sort rgb-list :key #'cadr)) (setf col-b (sort rgb-list :key #'caddr))))) (cl-defmethod bad-color-more ((s studio) col &optional less _bg) (with-slots (col-r col-g col-b) s (unless (and col-r col-g col-b) (bad-rgb-list s)) (let ((col-cur (frame-parameter nil 'foreground-color)) (lst)) (cl-case col ((red quote) (setq lst col-r)) ((green quote) (setq lst col-g)) ((blue quote) (setq lst col-b))) (when #1=(cl-position col-cur lst :key #'cadddr :test #'equal) (let* ((i (if less (1- #1#) (1+ #1#))) (col (cadddr (nth i lst)))) (message "%s" col) (set-foreground-color col)))))) (defun bad-random-color (&optional which) (cl-labels ((do-fg (&optional col) (set-foreground-color (or col (seq-random-elt (defined-colors))))) (do-bg (&optional col) (set-background-color (or col (seq-random-elt (defined-colors)))))) (cl-case which (fg (do-fg)) (bg (do-bg)) (_ (progn (do-fg) (do-bg)))))) (cl-defmethod bad-set-color ((s studio)) (with-slots (sel) s (when sel (with-slots (color) sel (setf color (bad-random-color))) (bad-update s)))) ;; ----------------------------------------------------------------------- (cl-defmethod bad-set-corner ((s studio) &optional pat) (with-slots (sel) s (when (and sel (box-p sel)) (let ((str (or pat (read-string (format "pattern? (1-4 chars) [%s] " #1="1234") nil nil #1#)))) (let* ((cs (string-to-list str)) (len (length cs))) (cl-case len (1 (bad-set-corner s (make-string 4 (car cs)))) (2 (let ((cs-fst (car cs)) (cs-snd (cadr cs))) (bad-set-corner (format "%c%c%c%c" cs-fst cs-snd cs-fst cs-snd)))) (3 (bad-set-corner (format "%c%c%c%c" (nth 0 cs) (nth 1 cs) (nth 2 cs) (nth 2 cs)))) (4 (dotimes (i 4) (bad-corner sel i (nth i cs)))) (_ (prog1 nil (message "input 1-4 chars")))))) (bad-update s)))) ;; ----------------------------------------------------------------------- (cl-defmethod bad-cycle-size ((s studio)) (with-slots (sel size-funs) s (when (and sel size-funs) (with-slots (w h) sel (let ((old-w w) (old-h h)) (funcall (car size-funs) sel) (setf size-funs (bad-list-shift size-funs)) (when (and (= w old-w) (= h old-h)) (funcall (car size-funs) sel) (setq size-funs (bad-list-shift size-funs)))) (bad-update s))))) (cl-defmethod bad-cycle-pos ((s studio)) (with-slots (sel pos-funs) s (when (and sel pos-funs) (with-slots (x y) sel (let ((old-x x) (old-y y)) (funcall (car pos-funs) sel) (setf pos-funs (bad-list-shift pos-funs)) (when (and (= x old-x) (= y old-y)) (funcall (car pos-funs) sel) (setq pos-funs (bad-list-shift pos-funs)))) (bad-update s))))) ;; ----------------------------------------------------------------------- (cl-defmethod bad-draw-to-buf ((s studio) &optional e) (with-slots (sel) s (or e (setq e sel)) (when (cl-typep e 'elem) (with-slots (deleted) e (unless deleted (bad-draw-to-buf e))))) (bad-update s)) ;; ----------------------------------------------------------------------- (provide 'bad-studio)