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)


(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.")

(defvar *photogal/commands*
  '(("RET" . "Next")
    ("C-p" . "Prev")
    ("C-a" . "Add tag")
    ("C-d" . "Delete tag")
    ("C-f" . "Show filename")
    ("C-g" . "Refresh buffer")
    ("C-r" . "Resize photo")
    ("C-c" . "Commit all")
    ("C-n" . "Name the file")
    ("C-o" . "Add a dir")))

(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-folders-for-file (photo-filepath)
  "what folders does this file have?"
  (photogal--get-folders (photogal--lookup-photo photo-filepath)))
(defun photogal-set-folders-for-file (photo-filepath folders)
  "make this file have these folders"
  (photogal--set-folders (photogal--lookup-photo photo-filepath) folders))

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

(defun photogal-mark-photo-for-copying (photo-filepath)
  "toggle on to copy this file. Warning: marks file for committing."
  (plist-put (photogal--lookup-photo photo-filepath)
	     'copy-to-dir t))
(defun photogal-unmark-photo-for-copying (photo-filepath)
  "toggle on to NOT copy this file. Warning: will not commit file."
  (plist-put (photogal--lookup-photo photo-filepath)
	     'copy-to-dir nil))

(defun photogal-photo-valid-for-committing? (photo-filepath)
  (let ((all-fields-for-photo
	 (mapcar (lambda (field) (plist-get (photogal--lookup-photo photo-filepath)
					    field))
		 '(tags name))))

    (seq-some (lambda (field) (not (eq nil field)))
	      all-fields-for-photo)))

(defun photogal-file-marked-for-copying? (photo-filepath)
  (plist-get (photogal--lookup-photo photo-filepath)
	     'copy-to-dir ))

;; //             internal           \\ ;;
(defun photogal--lookup-photo (photo-filepath)
  (seq-find (lambda (photo)
	      (string= (photogal--get-filepath photo) photo-filepath))
   *photogal/operating-table*))

(defun photogal--get-filepath (photo)
  (plist-get photo 'filepath))
(defun photogal--get-tags (photo)
  "What are all the tags for this file?"
  (plist-get photo 'tags))
(defun photogal--set-tags (photo tags)
  (plist-put photo 'tags
	     tags))
(defun photogal--get-folders (photo)
  "What are all the folders for this file?"
  (plist-get photo 'folders))
(defun photogal--set-folders (photo folders)
  (plist-put photo 'folders
	     folders))
(defun photogal--get-name (photo)
  (plist-get photo 'name))
(defun photogal--set-name (photo name)
  (plist-put photo 'name
	     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))

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


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

(defun photogal-make-photo (filepath)
  `(filepath ,filepath
	     tags ,nil
	     name ,nil
	     folders ,(list *photogal/operating-photo-dir*)
	     copy-to-dir ,nil))

(defun photogal-init-operating-table ()
  (setq *photogal/operating-table*
	(mapcar (lambda (photo)
		  (photogal-make-photo 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)
  "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)))

;;;;  --  ----  --  -     DEST DIRS     -  --  ----  --  ;;;;

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

(defun photogal-give-a-folder (name)
  (interactive ;"sWhat folder do u wannan put this in ")
   (list (read-directory-name
	  "What folder do u wannan put this in " photogal-default-directory)))
  (let ((folder-name (directory-file-name name)))
    (photogal-add-folder-for-file (photogal-current-file) folder-name)
    (photogal-mark-photo-for-copying (photogal-current-file))
    (photogal-refresh-buffer)))

;;;;  --  ----  --  -     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-mark-photo-for-copying (photogal-current-file))
  (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)
      (photogal-index-tracker)

      (if (photogal-file-marked-for-copying? photo-file-path)
	  (progn
	    (insert "\t\t\t\t    will commit?: ")
	    (photogal--insert-print-color "✓" "SeaGreen3"))
	(progn
	  (insert "\t\t\t\t    will commit?: ")
	  (photogal--insert-print-color "✗" "red")))
      (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)))
      (let ((padding "\n"))
	(if (photogal-get-name-for-file photo-file-path)
	  (insert (format  "\nName: %s" (photogal-get-name-for-file photo-file-path)))
	  (setq padding (concat padding "\n")))
	(if (photogal-get-folders-for-file photo-file-path)
	    (photogal--insert-print-color
	     (format  "\ndest dir: %s"
		      (photogal-get-folders-for-file photo-file-path))
	     "light gray")
	  (setq padding (concat padding "\n")))

	(insert padding))




      (insert "\n")
      (photogal--insert-print-color "Tag:\n" "red")
      (photogal-insert-tags-to-buffer photogal/tags)
      (photogal--insert-print-color "\n\nCommands:\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") ;; useful to know when screen re-draws
  (progn ; useful stuff to run every page draw
    (if (not (photogal-photo-valid-for-committing? (photogal-current-file)))
	(photogal-unmark-photo-for-copying (photogal-current-file))))
  (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-index-tracker ()
  ;; this is a little expensive, running photogal-all-photos
  ;; on every paint, but i'd like to have the file count
  ;; be very accurate.
  (let ((current-index
	 (+ 1 (seq-position
	       (photogal-all-photos *photogal/photos-origin-directory*)
	       (photogal-current-file))))
	(total-photos
	 (length (photogal-all-photos *photogal/photos-origin-directory*))))
    (insert "  ur lookin at photo ")
    (photogal--insert-print-color current-index "red")
    (insert " of ")
    (photogal--insert-print-color total-photos "red")))


;;;;  --  ----  --  - 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 16 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 24)))
	  commands))

(defun photogal--pprint-key-command (key-to-type name-of-command padding &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 "SeaGreen3")
      (photogal--insert-print-color key-to-type "dark gray"))
    (insert "] ")
    (photogal--insert-print-color name-of-command "blue" (- padding (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-mark-photo-for-copying (photogal-current-file))
       (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
   (let (( new-name (concat
		     (photogal-files--generate-unique-identifier filepath)
		     "-"
		     (format-time-string "%M%H,%d%m%y")
		     "-"
		     name
		     "-_"
		     (string-join tags "_")
		     "_")))
     (if (file-name-extension filepath)
	 (file-name-with-extension new-name (file-name-extension filepath))
       new-name))))

(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-compile-and-commit ()
  (interactive)
  (if (y-or-n-p (format  "Are u sure? "))
      (photogal-heavy-move-files-to-directory)
    (message "whoops")))

(defun photogal-heavy-move-files-to-directory ()
  ;; THIS DOES A LOTTA SHIT!!!
  (defun rename-file-to-folders (file-rename)
    (let ((origin (car file-rename))
	  (new-name (cdr file-rename)))
      (when (photogal-photo-valid-for-committing? origin)
	(let ((dest-dirs (photogal-get-folders-for-file origin)))
	  (mapcar (lambda (directory)
		    (make-directory directory 'parents)
		    (let ((new-file-name (expand-file-name new-name directory)))
		      (message (format "renaming %s to %s" origin new-file-name))
		      (copy-file origin new-file-name)))
		  dest-dirs)
	  (delete-file origin)))))
  (let* ((new-names (photogal-files--new-filenames-for-photos)))
    (mapcar
     #'rename-file-to-folders
     new-names)
    (photogal-restart)))

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

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

(defvar key-commands
  '(("G" . photogal-refresh-buffer)
    ("RET" . photogal-next-file)
    ("<right>" . photogal-next-file)
    ("SPC" . photogal-next-file)
    ("C-p" . photogal-prev-file)
    ("<left>" . photogal-prev-file)
    ("C-a" . photogal-add-tag)
    ("C-d" . photogal-delete-tag)
    ("C-f" . photogal-show-filepath)
    ("C-r" . photogal-resize-photo)
    ("C-c" . photogal-compile-and-commit)
    ("C-n" . photogal-name-the-file)
    ("C-o" . photogal-give-a-folder)))


(progn
  (setq photogal-mode-map (make-sparse-keymap))
  (map-do (lambda (key command)
	    (eval `(define-key photogal-mode-map (kbd ,key) ',command)))
	  key-commands))

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