photogal/photogal.el

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;    PHOTOGAL    ;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; v1.0 ;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                         ;;
;;  author: jordyn                          ,   -    *     ;;
;;  authored: spokane valley, summer '22      .          ` ;;
;;                                                 ^ ~     ';
;;    PHOTO                *    ,    '  . `   `  *      ,  ;;
;;    , Grouper         '    `     .   ,* -   .            ;;
;; .      And        ,    ^ '  .  '  .   `  `      '       ;;
;;    `     Labeler    '   ,     * '      *                ;;
;;  ,     .   ,     `        '        .                    ;;
;;   '           -     '        ,                          ;;
;;                                                         ;;
;;                                                         ;;
;;  ;;  ;;  ;;  ;;  ;;  ;;  ;;  ;;  ;;  ;;  ;;  ;;  ;; ;;  ;;



;;;;  --  ----  --  -      DATA         -  --  ----  --  ;;;;

(defvar *photogal/operating-photo-dir* nil)
(defvar *photogal/all-photos* nil)
(defvar *photogal/operating-table* nil)
(defvar *photogal/--resize-photo* nil)
(defvar *photogal/photos-origin-directory* nil)
(defvar *photogal/commands*
  '(("RET" . "Next")
    ("P" . "Prev")
    ("A" . "Add tag")
    ("D" . "Delete tag")
    ("F" . "Show filename")
    ("G" . "Refresh buffer")
    ("R" . "Resize photo")
    ("C" . "Compile and commit")
    ("N" . "Name the file")))

(defcustom photogal-default-directory "/Users/jwd/bench/photos/"
  "This is where photogal will look for photos.")

(defcustom photogal/tags
  '(("a" . "art")
    ("c" . "cityscape")
    ("f" . "family")
    ("g" . "good")
    ("h" . "screenshot")
    ("l" . "politics")
    ("m" . "meme")
    ("o" . "computer")
    ("p" . "portrait")
    ("r" . "reaction-photo")
    ("t" . "photography")
    ("s" . "selfie"))
    "Tags and key-command to associate to photos.")

(defun photogal-get-tags-for-file (photo-filepath)
  "what tags does this file have?"
  (photogal--get-tags (photogal--lookup-photo photo-filepath)))
(defun photogal-set-tags-for-file (photo-filepath tags)
  "make this file have these tags"
  (photogal--set-tags (photogal--lookup-photo photo-filepath) tags))
(defun photogal-get-name-for-file (photo-filepath)
  "does this file have a user-given name?"
  (photogal--get-name (photogal--lookup-photo photo-filepath)))
(defun photogal-set-name-for-file (photo-filepath name)
  "give this file a Proper name. (embedded in final filename) (optional)"
  (photogal--set-name (photogal--lookup-photo photo-filepath) name))

;; //             internal           \\ ;;
(defun photogal--get-filepath (photo)
  (car photo))
(defun photogal--lookup-photo (photo-filepath)
  (assoc photo-filepath *photogal/operating-table*))
(defun photogal--get-tags (photo)
  "What are all the tags for this file?"
  (caadr photo))
(defun photogal--set-tags (photo tags)
  (setcar (cadr photo)
	  tags))
(defun photogal--get-name (photo)
  (cadadr photo))
(defun photogal--set-name (photo name)
  (setcar (cdadr photo)
	  name))
;; \\             internal           // ;;

(defun photogal-advance-photo ()
  "Move forward by one photo."
  (setq *photogal/all-photos*
	(append (cdr *photogal/all-photos*) (list (car *photogal/all-photos*)))))

(defun photogal-rewind-photo ()
  "Reverse by one photo."
  (setq *photogal/all-photos*
	(append (last *photogal/all-photos*) (butlast *photogal/all-photos*))))


;;;;  --  ----  --  -      THE APP      -  --  ----  --  ;;;;



(defun photogal (photo-dir)
  (interactive
   (list (read-directory-name
	  "where are ur photos? " photogal-default-directory)))
  (setq *photogal/photos-origin-directory* (directory-file-name photo-dir))
  (setq *photogal/operating-photo-dir* (concat *photogal/photos-origin-directory* "-photogal"))
  (setq *photogal/all-photos* (photogal-all-photos *photogal/photos-origin-directory*))
  (photogal-init (photogal-current-file))
  (photogal-init-operating-table)
  (photogal-generate-tag-commands))



;;;;  --  ----  --  -  INITIALIZATION   -  --  ----  --  ;;;;

(defun photogal-init-operating-table ()
  (setq *photogal/operating-table*
	(mapcar (lambda (photo)
		  ;; '(old-file-path (tags optional-name))
		  (list photo (list '() nil)))
		*photogal/all-photos*)))

(defun photogal-generate-tag-commands ()
  "Generate and activate M-x (photogal-toggle-tag-TAG) to tag curent photo,
for all tags defined -- one function per tag."
  (mapcar (lambda (tag)
	    (let ((tag-key (car tag))
		  (tag-name (cdr tag)))
	      (eval `(photogal-generate-tagger ,(intern tag-name)))
	      (define-key photogal-mode-map (kbd tag-key)
		(intern (format "photogal-toggle-tag-%s" tag-name)))))
	  photogal/tags))

;;;;  --  ----  --  -        TAG        -  --  ----  --  ;;;;

(defun photogal-add-tag (new-tag new-tag-code)
  "Add a user-generated tag to the tag library."
  (interactive "sNew tag: \nsTag code (length 1): ")
  (let ((tag-code-too-long (> (length new-tag-code) 1))
	(tag-code-in-use (photogal-tag-code-in-use new-tag-code)))
    (if (or tag-code-too-long tag-code-in-use)
	(progn (message "tag code must be a single character and can't be already in use")
	       (call-interactively 'photogal-add-tag))
      (photogal--add-tag new-tag new-tag-code)
      (photogal-refresh-buffer))))

(defun photogal-delete-tag (tag-code)
  "Remove a tag from the library."
  (interactive "sDelete tag: ")
  (customize-save-variable
   'photogal/tags
   (seq-remove (lambda (tag) (string= (car tag) tag-code)) photogal/tags))
  (photogal-refresh-buffer))

(defun photogal--add-tag (new-tag new-tag-code)
  "Modify the defcustom var to the new collection of tags."
  (let ((escaped-str-tag (string-replace " " "-" new-tag)))
    (customize-save-variable
     'photogal/tags
     (cons (cons new-tag-code escaped-str-tag) photogal/tags)))
  (photogal-generate-tag-commands))

(defun photogal-tag-code-in-use (tag-code)
  (seq-contains-p
   photogal/tags tag-code
   (lambda (tag test) (string= (car tag) test))))

;;;;  --  ----  --  -   TAGGING FILES   -  --  ----  --  ;;;;

(defun photogal-for-file-toggle-tag (file tag)
  "If a file has the tag, remove it. If it doesn't have it, add it."
  (if (photogal-file-has-tag? file tag)
      (photogal-rm-tag-from-file file tag)
    (photogal-add-tag-to-file file tag)))

(defun photogal-add-tag-to-file (file tag)
  "Append new tag for a file."
  (let ((tags (photogal-get-tags-for-file file)))
    (photogal-set-tags-for-file file
		       (seq-sort #'string< (seq-uniq (cons tag tags))))))

(defun photogal-rm-tag-from-file (file tag)
  "Dissociate tag from file."
  (defun tags-without-tag (tags tag)
    (seq-sort
     #'string<
     (seq-uniq
      (seq-remove
       (lambda (tg) (string= tg tag)) tags))))
  (let ((tags (photogal-get-tags-for-file file)))
    (photogal-set-tags-for-file file
	    (tags-without-tag tags tag))))

(defun photogal-file-has-tag? (file tag)
  "Does this file have this tag?"
  (let ((tags (photogal-get-tags-for-file file)))
    (seq-contains-p tags tag)))


;;;;  --  ----  --  -     FILE NAME     -  --  ----  --  ;;;;

(defun photogal-name-the-file (name)
  (interactive "sWhat do u want to name this file? ")
  (photogal-set-name-for-file
   (photogal-current-file)
   (string-replace " " "-"  name))
  (photogal-refresh-buffer))

;;;;  --  ----  --  -      FILE OPS     -  --  ----  --  ;;;;

(defun photogal-all-photos (directory)
  "Give me a list of all the photos in my operating directory."
  (directory-files directory
		   t directory-files-no-dot-files-regexp))

(defun photogal-current-file ()
  "What is the file currently being operated on?"
  (car *photogal/all-photos*))

;;;;  --  ----  --  -       U I         -  --  ----  --  ;;;;
(defun photogal-init (photo-file-path &optional show-filepath)
  "Set everything up in the buffer."
  (let ((buf (get-buffer-create "photogal")))
    (with-current-buffer buf
      (photogal-mode)
      (erase-buffer)
      (insert "\n")
      (insert " ")
      (insert-image
       (if *photogal/--resize-photo*
	   (create-image photo-file-path 'imagemagick nil
			 :width (- (window-pixel-width) 75))
	 (create-image photo-file-path 'imagemagick nil
		       :height (/ (window-pixel-height) 2))))
      (insert "\n\nCurrent tags: ")
      (insert (format "%s" (photogal-get-tags-for-file photo-file-path)))
      (if (photogal-get-name-for-file photo-file-path)
	  (insert (format  "\nName: %s" (photogal-get-name-for-file photo-file-path)))
	(insert "\n"))
      (insert "\n\n")
      (photogal--insert-print-color "Tag:\n\n" "red")
      (photogal-insert-tags-to-buffer photogal/tags)
      (photogal--insert-print-color "\n\nCommands:\n\n" "red")
      (photogal-insert-commands-to-buffer
       *photogal/commands*)
      (when show-filepath
	(insert "\n\n")
	(insert (photogal-current-file))))
    (switch-to-buffer buf)))

(defun photogal-next-file ()
  (interactive)
  (photogal-advance-photo)
  (photogal-refresh-buffer))

(defun photogal-prev-file ()
  (interactive)
  (photogal-rewind-photo)
  (photogal-refresh-buffer))

(defun photogal-refresh-buffer (&optional show-filepath)
  "Refresh buffer."
  (interactive)
  (message "refreshing buffer")
  (photogal-init (photogal-current-file) show-filepath)
  (photogal-generate-tag-commands)
  (beginning-of-buffer))

(defun photogal-resize-photo ()
  (interactive)
  (setq *photogal/--resize-photo* (not *photogal/--resize-photo*))
  (photogal-refresh-buffer))

(defun photogal-show-filepath ()
  (interactive)
  (photogal-refresh-buffer t))

;;;;  --  ----  --  - LO-LEVEL DISPLAY  -  --  ----  --  ;;;;
;; this stuff paints the words on the screen, changing     ;;
;; color, etc, pprinting stuff at a pretty granular and    ;;
;; tediously technical level.                              ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun photogal-insert-tags-to-buffer (tags)
  "Pretty print the tags with their toggle key."
  (mapcar (lambda (tag)
	    (let* ((key-command (car tag))
		   (tag-name (cdr tag))
		   (activated (photogal-file-has-tag? (photogal-current-file) tag-name)))
	      (photogal--pprint-key-command key-command tag-name activated)))
	  (seq-sort (lambda (t1 t2) (string< (car t1) (car t2))) tags)))

(defun photogal-insert-commands-to-buffer (commands)
  "Pretty print the commands with their invoke key."
  (mapcar (lambda (command)
	    (let ((key-command (car command))
		  (command-name (cdr command)))
	      (photogal--pprint-key-command key-command command-name)))
	  commands))

(defun photogal--pprint-key-command (key-to-type name-of-command &optional activated)
  "Make the low-level insertions to the buffer to render a key-command."
  (let ((length-of-unit (+ (length key-to-type) (length name-of-command) 3)))
    (when (> (+ (+ (current-column) length-of-unit)
		10)
	     (window-width))
	(insert "\n"))
    (insert "[")
    (if activated
	(photogal--insert-print-color key-to-type "SeaGreen2")
      (photogal--insert-print-color key-to-type "dark gray"))
    (insert "] ")
    (photogal--insert-print-color name-of-command "blue" (- 16 (length key-to-type)))
    (insert " ")))

(defun photogal--insert-print-color (string-to-insert-to-buffer color &optional padding)
  "Insert some text in this color."
  (let ((beg (point))
	(padding
	 (if padding
	     (format "%s" padding)
	   "0")))
    (insert (format (concat "%-" padding "s") string-to-insert-to-buffer))
    (put-text-property beg (point) 'font-lock-face `(:foreground ,color))))

;;;;  --  ----  --  -     META SHIT     -  --  ----  --  ;;;;
;; this is the coolest damn thing here.                    ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro photogal-generate-tagger (name)
  "Generate function to toggle a tag which is itself on the current file.
One of these is needed per tag. For instance if you want to create the tag
'cool', you can run and evaluate (photogal-generate-tagger cool) to create a new
function `photogal-toggle-tag-cool` that will toggle the tag 'cool' for
the current file."
  (let ((my-funcname (intern (format "photogal-toggle-tag-%s" name))))
    `(defun ,my-funcname ()
       (interactive)
       (photogal-for-file-toggle-tag (photogal-current-file) ,(format "%s" name))
       (photogal-refresh-buffer))))

;;;;  --  ----  --  -MOVING FILES AROUND-  --  ----  --  ;;;;

(defun photogal-files--get-extension (filepath)
  (file-name-extension filepath))

(defun photogal-files--generate-unique-identifier (filepath)
  "Not GUARANTEED unique, but probably unique enough for my purposes."
  (seq-take (md5 (concat (current-time-string) filepath))
	    6))

(defun photogal-files--new-file-name-for-photo (filepath tags name)
  (cons
   filepath
   (file-name-with-extension
    (file-name-concat
     *photogal/operating-photo-dir*
     (concat
      (photogal-files--generate-unique-identifier filepath)
      "-"
      (format-time-string "%M%H,%d%m%y")
      "-"
      name
      "-_"
      (string-join tags "_")
      "_"
      ))
    (file-name-extension filepath))))

(defun photogal-files--new-filenames-for-photos ()
  (mapcar
   (lambda (photo)
     (let ((filepath (photogal--get-filepath photo))
	   (tags (photogal--get-tags photo))
	   (name (photogal--get-name photo)))
       (photogal-files--new-file-name-for-photo filepath tags name)))
   *photogal/operating-table*))

(defun photogal-restart ()
  (setq *photogal/all-photos* (photogal-all-photos *photogal/photos-origin-directory*))
  (photogal-init-operating-table)
  (photogal-init (photogal-current-file)))

(defun photogal-compile-and-commit ()
  (interactive)
  (if (y-or-n-p (format  "Are u sure? "))
      (progn
	(make-directory *photogal/operating-photo-dir* 'parents)
	(mapcar
	 (lambda (file-rename)
	   (let ((origin (car file-rename))
		 (destination (cdr file-rename)))
	     (when (or (photogal-get-tags-for-file origin)
		       (photogal-get-name-for-file origin))
	       (rename-file origin destination))))
	 (photogal-files--new-filenames-for-photos))
	(photogal-restart))
    (message "whoops")))

;;;;  --  ----  --  -   KEY BINDINGS    -  --  ----  --  ;;;;

(defvar photogal-mode-map nil "Keymap for `photogal-mode`")

(progn
  (setq photogal-mode-map (make-sparse-keymap))
  (define-key photogal-mode-map (kbd "G") 'photogal-refresh-buffer)
  (define-key photogal-mode-map (kbd "RET") 'photogal-next-file)
  (define-key photogal-mode-map (kbd "<right>") 'photogal-next-file)
  (define-key photogal-mode-map (kbd "SPC") 'photogal-next-file)
  (define-key photogal-mode-map (kbd "P") 'photogal-prev-file)
  (define-key photogal-mode-map (kbd "<left>") 'photogal-prev-file)
  (define-key photogal-mode-map (kbd "A") 'photogal-add-tag)
  (define-key photogal-mode-map (kbd "D") 'photogal-delete-tag)
  (define-key photogal-mode-map (kbd "F") 'photogal-show-filepath)
  (define-key photogal-mode-map (kbd "R") 'photogal-resize-photo)
  (define-key photogal-mode-map (kbd "C") 'photogal-compile-and-commit)
  (define-key photogal-mode-map (kbd "N") 'photogal-name-the-file))

(define-derived-mode photogal-mode text-mode "photogal"
  "Major mode for grouping and labeling images.")