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/commands*
  '(("RET" . "Next")
    ("P" . "Prev")
    ("A" . "Add tag")
    ("D" . "Delete tag")
    ("F" . "Show filename")
    ("G" . "Refresh buffer")
    ("R" . "Resize photo")
    ("C" . "Compile and commit")))

(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"))
    "These are photo tags and the key to activate them.")


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



(defun photogal (photo-dir)
  (interactive
   (list (read-directory-name
	  "where are ur photos? " photogal-default-directory)))
  (let ((photos-origin-directory (directory-file-name photo-dir)))
    (setq *photogal/operating-photo-dir* (concat photos-origin-directory "-photogal"))
    (setq *photogal/all-photos* (photogal-all-photos 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)
		  (cons '() photo))
		*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)
  (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))))

(defun photogal-delete-tag (tag-code)
  (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)
  (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)
  (photogal-refresh-buffer))

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

(defun photogal-tags-for-file (file)
  "Give the tags that this file has."
  (car (rassoc file *photogal/operating-table*)))

;;;;  --  ----  --  -   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-tags-for-file file)))
    (setcar (rassoc file *photogal/operating-table*)
	    (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-tags-for-file file)))
    (setcar (rassoc file *photogal/operating-table*)
	    (tags-without-tag tags tag))))

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

(defun photogal-get-tags-for-file (file)
  "What are all the tags for this file?"
  (car (rassoc file *photogal/operating-table*)))


;;;;  --  ----  --  -      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)))
      (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)
  (setq *photogal/all-photos*
	(append (cdr *photogal/all-photos*) (list (car *photogal/all-photos*))))
  (photogal-refresh-buffer))

(defun photogal-prev-file ()
  (interactive)
  (setq *photogal/all-photos*
	(append (last *photogal/all-photos*) (butlast *photogal/all-photos*)))
  (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))

(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     -  --  ----  --  ;;;;

(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)
  (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")
      "_"
      (string-join tags "_")
      ))
    (file-name-extension filepath))))

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

(defun photogal-compile-and-commit ()
  (interactive)
  (if (y-or-n-p (format  "Are u sure? "))
    (mapcar
     (lambda (file-rename)
       (let ((origin (car file-rename))
	     (destination (cdr file-rename)))
	 (copy-file origin destination)))
     (photogal-files--new-filenames-for-photos))
    (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 "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-derived-mode photogal-mode text-mode "photogal"
  "Major mode for grouping and labeling images.")