(defvar *photogal/photoreel* nil) (defvar *photogal/tags* '( ("e" . (name "spokane" ;; phg will not display parent ("L" . (name "Location")))) ;; differences in the ("n" . (name "new-york" ;; names of tag parent ("L" . (name "Locution")))) ;; parents. they will be ("e" . (name "emma-chamberlain" ;; considered the same. parent ("C" . (name "Celebrity")))) ("x" . (name "lil-nas-x" parent ("C" . (name "Celebrity")))) ("a" . (name "art")) ("c" . (name "cityscape")) ("f" . (name "family")) ("g" . (name "good")) ("h" . (name "screenshot")) ("l" . (name "politics")) ("m" . (name "meme")) ("o" . (name "computer")) ("p" . (name "portrait")) ("r" . (name "reaction-photo")) ("t" . (name "photography")) ("s" . (name "selfie")))) (defcustom photogal-default-directory "/Users/jwd/bench/photos/" "This is where photogal will look for photos.") (defun photogal-create-photo-roll (photo-dir) (defun photogalroll--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 photogalroll--generate (destination-dir) (mapcar (apply-partially #'photogalroll--make-photo-entry destination-dir) (photogalroll--all-photos photo-dir))) (let ((destination-dir (concat photo-dir "-photogal")) (idx 0)) (mapcar (lambda (photo) (photogal--set-index photo (cl-incf idx))) (photogalroll--generate destination-dir)))) (defun photogal-current-file (photoreel) "What is the file currently being operated on?" (car photoreel)) (defun photogal-advance-file (photoreel) "Move forward by one photo." (append (cdr photoreel) (list (car photoreel)))) (defun photogal-rewind-file (photoreel) "Reverse by one photo." (append (last photoreel) (butlast photoreel))) (defun photogal3 (photo-dir) (interactive (list (read-directory-name "where are ur photos? " photogal-default-directory))) (setq *photogal/photoreel* (photogal-create-photo-roll photo-dir)) (photogal-render *photogal/photoreel* *photogal/tags*)) (defun photogal-render (photoreel tags) (photogal-draw-buffer photoreel "photogal3" tags)) (defun photogal-refresh () (photogal-render *photogal/photoreel* *photogal/tags*)) (defun photogal-tag-current-photo (tag) (photogaltag-toggle tag (photogal-current-file *photogal/photoreel*))) (defun photogaltag-tags= (tag1 tag2) ;; tags are equal ONLY when their keys are the same (string= (photogal-tag-key tag1) (photogal-tag-key tag2))) (defun photogaltag-tags< (tag1 tag2) (string< (photogal-tag-key tag1) (photogal-tag-key tag2))) (defun photogaltag-is-parent (tag) ;; 91 is '[', right after 'Z' in the ascii table (< (string-to-char (photogal-tag-key tag)) 91)) (defun photogaltag-is-parent-or-child (mytag) (or (photogaltag-is-parent mytag) (photogal-tag-parent mytag))) (defun photogaltag-add-tag (tag photo) (let ((tags (photogal--get-tags photo))) (photogal--set-tags photo (seq-sort #'photogaltag-tags< (seq-uniq (cons tag tags) #'photogaltag-tags=))))) (defun photogaltag-rm-tag (tag photo) (photogal--set-tags photo (seq-remove (apply-partially #'photogaltag-tags= tag) (photogal--get-tags photo)))) (defun photogaltag-has-tag-p (tag photo) (seq-contains-p (photogal--get-tags photo) tag #'photogaltag-tags=)) (defun collapse-tag (tag) (let* ((parent (photogal-tag-parent tag)) (parent-key (photogal-tag-key parent)) (parent-name (photogal-tag-name parent)) (child-name (photogal-tag-name tag)) (child-key (photogal-tag-key tag))) (list child-key 'name (concat child-name parent-name)))) (defun photogaltag-toggle (tag photo) "If a photo has the tag, remove it. If it doesn't have it, add it." (if (photogaltag-has-tag-p tag photo) (photogaltag-rm-tag tag photo) (photogaltag-add-tag tag photo))) ;; // PHOTO DATAOBJECT \\ ;; (defun photogalroll--make-photo-entry (destination-dir filepath) `(filepath ,filepath tags ,nil name ,nil folders ,(list destination-dir) copy-to-dir ,nil index ,-1 )) (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-index (photo) (plist-get photo 'index)) (defun photogal--set-index (photo index) (plist-put photo 'index index)) (defun photogal--get-copy-to-dir? (photo) (plist-get photo 'copy-to-dir)) (defun photogal--set-copy-to-dir? (photo copy-to-dir) (plist-put photo 'copy-to-dir copy-to-dir)) ;; \\ // ;; (defun photogal-engage-keys-for-tags (tags) (mapcar (lambda (tag) (let ((key (photogal-tag-key tag))) (eval `(define-key photogal3-mode-map (kbd ,key) (lambda () (interactive) (photogal-tag-current-photo ',tag) (photogal-refresh)))) )) tags)) (defun photogal-engage-keys-for-parents (parent-tags) (mapcar (lambda (tag) (let ((key (photogal-tag-key tag))) (eval `(define-key photogal3-mode-map (kbd ,key) (lambda () (interactive) (photogal-tag-family ',tag) ;; (photogal-refresh) ))) )) parent-tags)) (defun photogal-tag-family (parent-tag) (photogal-render *photogal/photoreel* (mapcar #'collapse-tag (photogal-child-tags-belonging-to parent-tag *photogal/tags*)))) ;; //////////////// |||||||||||||||| //////////////// ;; ;; ^^^^ ^^^^ ^^^^ work zone ^^^^ ^^^^ ^^^^ (defun photogaldraw-activate-key-commands (active-tags) (photogal-engage-keys-for-tags (photogal-tags-with-no-parents active-tags)) (photogal-engage-keys-for-parents (photogal-all-parents *photogal/tags*)) (mapcar (lambda (key-command) (let ((key (car key-command)) (function (cadr key-command)) (info-message (caddr key-command)) (display (cadddr key-command))) (eval `(define-key photogal3-mode-map (kbd ,key) (lambda () (interactive) (message ,info-message) (funcall #',function)))))) key-commands) ) (defun photogaldraw-index-tracker (photoreel) (let* ((current-file (photogal-current-file photoreel)) (current-index (photogal--get-index current-file)) (total-photos (length photoreel))) (insert " ur lookin at photo ") (photogal--insert-print-color current-index "red") (insert " of ") (photogal--insert-print-color total-photos "red"))) (defun photogaldraw--commit-message (photo) (if (photogal--get-copy-to-dir? photo) (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")))) (defun photogaldraw--insert-image (filepath) (insert " ") (insert-image (if resize-image (create-image filepath 'imagemagick nil :width (- (window-pixel-width) 75)) (create-image filepath 'imagemagick nil :height (/ (window-pixel-height) 2))))) (defun photogaldraw--insert-photo-tags (photo) (photogaldraw--newline) (photogaldraw--newline) (insert "Current tags: ") (insert (format "%s" (mapcar #'photogal-tag-name (photogal--get-tags photo)))) (photogaldraw--newline)) (defun photogaldraw--insert-tags (tags photo) (photogal--insert-print-color "Tag:\n" "red") (mapcar (lambda (tag) (let* ((key-command (photogal-tag-key tag)) (tag-name (photogal-tag-name tag)) (activated (photogaltag-has-tag-p tag photo))) (photogal--pprint-key-command key-command tag-name 16 activated))) tags)) (defun photogaldraw--insert-commands-to-buffer (commands) "Pretty print the commands with their invoke key." (photogaldraw--newline) (photogaldraw--newline) (photogal--insert-print-color "Commands:" "red") (photogaldraw--newline) (mapcar (lambda (command) (let ((key-command (car command)) (display-copy (caddr command))) (when display-copy ;; only show command if it has description (photogal--pprint-key-command key-command display-copy 16)))) commands)) (defun photogaldraw--newline () (insert "\n")) (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)))) (defun photogal-draw-buffer (photoreel buffer tags) (let* ((current-photo (photogal-current-file photoreel)) (resize-image nil) (photo-file-path (photogal--get-filepath current-photo)) (buf (get-buffer-create buffer)) (display-tags (photogal-top-level-tags tags))) (with-current-buffer buf (photogal3-mode) (erase-buffer) (photogaldraw-index-tracker photoreel) (photogaldraw--commit-message current-photo) (photogaldraw--newline) (photogaldraw--insert-image (photogal--get-filepath current-photo)) (photogaldraw--newline) (photogaldraw--insert-photo-tags current-photo) (photogaldraw--newline) (photogaldraw--insert-tags display-tags current-photo) (photogaldraw--newline) (photogaldraw--insert-commands-to-buffer key-commands) (switch-to-buffer buf) (photogaldraw-activate-key-commands tags)))) (defvar key-commands '( ("RET" photogal-next-file "next") ("" photogal-next-file nil) ("SPC" photogal-next-file nil ) ("C-p" photogal-prev-file "prev") ("" photogal-prev-file nil) ;; ("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) ("C-g" photogal-refresh "redraw buffer!") )) (defun photogal-next-file () "Advance by one photo." (interactive) (setq *photogal/photoreel* (photogal-advance-file *photogal/photoreel*)) (photogal-render *photogal/photoreel* *photogal/tags*)) (defun photogal-prev-file () "Reverse by one photo." (interactive) (setq *photogal/photoreel* (append (last *photogal/photoreel*) (butlast *photogal/photoreel*))) (photogal-render *photogal/photoreel* *photogal/tags*)) ;; // tag shit (defun photogal-all-parents (tags) (seq-filter (lambda (x) x) (seq-uniq (mapcar (lambda (tag) (plist-get (cdr tag) 'parent)) tags) (lambda (a b) (string= (car a) (car b)))))) (defun photogal-child-tags-belonging-to (parent tags) (seq-filter (lambda (tag) (photogaltag-tags= parent (photogal-tag-parent tag))) tags)) (defun photogal-tags-with-parents (tags) (seq-filter (lambda (tag) (plist-member (cdr tag) 'parent)) *photogal/tags*)) (defun photogal-tags-with-no-parents (tags) (seq-remove (lambda (tag) (plist-member (cdr tag) 'parent)) tags)) (defun photogal-top-level-tags (tags) (append (photogal-all-parents tags) (photogal-tags-with-no-parents tags))) (defun photogal-tag-name (tag) (plist-get (cdr tag) 'name)) (defun photogal-tag-parent (tag) (plist-get (cdr tag) 'parent)) (defun photogal-tag-key (tag) (car tag)) (defvar photogal3-mode-map nil "Keymap for `photogal-mode`") ;; (setq photogal3-mode-map nil) ;; (setq photogal3-mode-map (make-sparse-keymap)) (define-derived-mode photogal3-mode text-mode "photogal3" "Major mode for grouping and labeling images.") ;; (progn ;; (setq photogal-mode-map (make-sparse-keymap)) ;; (map-do (lambda (key command) ;; (eval `(define-key photogal-mode-map (kbd ,key) ',command))) ;; key-commands))