|
@@ -0,0 +1,605 @@
|
|
|
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
+;;;;;;;;;;;;;;;;;;;;;; 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.")
|
|
|
+
|
|
|
+(photogal-add-tag "Location" "L")
|
|
|
+(defun photogal-generate-group-tagger (group-key group-name)
|
|
|
+ (let ((tags (caddr (assoc group-key photogal/group-tags))))
|
|
|
+ (map-do (lambda (key name)
|
|
|
+ (photogal-add-tag (format "%s-%s" group-name name)
|
|
|
+ (format "%s%s" group-key key)))
|
|
|
+ tags)))
|
|
|
+(photogal-generate-group-tagger "L" "Location")
|
|
|
+
|
|
|
+
|
|
|
+(defcustom photogal/group-tags
|
|
|
+ '(("L" . ("Location"
|
|
|
+ (("b" . "new-york")
|
|
|
+ ("d" . "seattle")
|
|
|
+ ("e" . "spokane")))))
|
|
|
+ "tags in groups")
|
|
|
+
|
|
|
+(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-current-photo-for-copying ()
|
|
|
+ "toggle on to copy this file. Warning: marks file for committing."
|
|
|
+ (plist-put (photogal--lookup-photo (photogal-current-file))
|
|
|
+ 'copy-to-dir t))
|
|
|
+(defun photogal-unmark-current-photo-for-copying ()
|
|
|
+ "toggle on to NOT copy this file. Warning: will not commit file."
|
|
|
+ (plist-put (photogal--lookup-photo (photogal-current-file))
|
|
|
+ 'copy-to-dir nil))
|
|
|
+
|
|
|
+
|
|
|
+(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 (photogal-general-tag-list)))
|
|
|
+
|
|
|
+(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 (photogal-tags-including-families))))
|
|
|
+
|
|
|
+(defun photogal-tag-code-in-use (tag-code)
|
|
|
+ (seq-contains-p
|
|
|
+ photogal/tags tag-code
|
|
|
+ (lambda (tag test) (string= (car tag) test))))
|
|
|
+
|
|
|
+(defun photogal-tag-name-in-use (tag)
|
|
|
+ (seq-contains-p
|
|
|
+ photogal/tags tag
|
|
|
+ (lambda (tag test) (string= (cdr tag) test))))
|
|
|
+
|
|
|
+(defun photogal-tags-including-families ()
|
|
|
+ ;; ugly lol
|
|
|
+ (append photogal/tags (mapcar (lambda (x) (cons (car x) (cadr x))) photogal/group-tags)))
|
|
|
+
|
|
|
+(defun photogal-general-tag-list ()
|
|
|
+ "alist of tags without depth (families are flattened)"
|
|
|
+ (mapcar (lambda (tag) (let* ((key-command (car tag))
|
|
|
+ (tag-name (if (listp (cdr tag))
|
|
|
+ (car (cdr tag))
|
|
|
+ (cdr tag))))
|
|
|
+ `(,key-command . ,tag-name)))
|
|
|
+ photogal/tags))
|
|
|
+
|
|
|
+;;;; -- ---- -- - TAGGING FILES - -- ---- -- ;;;;
|
|
|
+
|
|
|
+(defun photogal-for-file-toggle-tag (tag)
|
|
|
+ "If a file has the tag, remove it. If it doesn't have it, add it."
|
|
|
+ (let ((file (current-file)))
|
|
|
+ (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)
|
|
|
+ (photogal-draw-ui photo-file-path (photogal-tags-including-families))
|
|
|
+ (switch-to-buffer buf))))
|
|
|
+
|
|
|
+(defun photogal-draw-ui (photo-file-path tags)
|
|
|
+ (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 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))))
|
|
|
+
|
|
|
+(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 (photogal-general-tag-list))
|
|
|
+ (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 - -- ---- -- ;;;;
|
|
|
+
|
|
|
+(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.")
|
|
|
+
|
|
|
+
|
|
|
+;;;
|
|
|
+
|
|
|
+;;new stuff:
|
|
|
+
|
|
|
+(defun make-tag (name key family)
|
|
|
+ (list name key family))
|
|
|
+
|
|
|
+(defun tag-name (tag) (intern (car tag)))
|
|
|
+(defun tag-key (tag) (cadr tag))
|
|
|
+(defun tag-family (tag) (caddr tag))
|
|
|
+
|