;;; my-pdf-tools.el -- Extensions for pdf-tools -*- lexical-binding: t -*-
;; Copyright (C) 2023 Free Software Foundation.
;; Author: Yuchen Pei <id@ypei.org>
;; Package-Requires: ((emacs "28.2"))
;; This file is part of dotfiles.
;; dotfiles is free software: you can redistribute it and/or modify it under
;; the terms of the GNU Affero General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; dotfiles is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
;; Public License for more details.
;; You should have received a copy of the GNU Affero General Public
;; License along with dotfiles. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Extensions for pdf-tools.
;;; Code:
(require 'pdf-tools)
(defvar my-pdf-view-current-node nil)
(defvar my-pdf-view-navigation-functions
'(my-pdf-view-forward-node
my-pdf-view-backward-node
my-pdf-view-forward-node-same-depth
my-pdf-view-backward-node-same-depth
my-pdf-view-backward-node-lower-depth))
(defun my-pdf-outline-update-with-path (outline)
(let ((path) (depth 0))
(dolist (node outline)
(let* ((node-depth (alist-get 'depth node))
(node-title (alist-get 'title node))
(depth-diff (- node-depth depth 1)))
(cond ((< depth-diff 0) (dotimes (unused (- depth-diff))
(pop path)))
((> depth-diff 0) (dotimes (unused depth-diff)
(push "" path))))
(push node-title path)
(setq depth node-depth))
(setf (alist-get 'title node) (string-join (reverse path) "/")))
outline))
(defun my-pdf-jump-and-set-current-node (node)
(pdf-links-action-perform node)
(setq my-pdf-view-current-node node))
(defun my-pdf-outline-jump ()
(interactive)
(let ((outline (my-pdf-outline-update-with-path
(pdf-info-outline (current-buffer)))))
(if (not outline) (message "PDF has no outline")
(let ((title (completing-read
"Jump to: "
(mapcar (lambda (node) (alist-get 'title node))
outline))))
(pdf-links-action-perform
(cl-find-if (lambda (node) (equal (alist-get 'title node) title))
outline))))))
(defun my-pdf-view-next-node-by-page (outline)
(cl-find-if (lambda
(node)
(> (alist-get 'page node) (pdf-view-current-page))) outline))
(defun my-pdf-view-next-node-by-node (current-node outline &optional depth-req)
(let ((next-node
(catch 'ret
(while outline
(when (equal (car outline) current-node)
(throw 'ret (cadr outline)))
(setq outline (cdr outline))))))
(cond ((not depth-req) next-node)
((eq depth-req 'same-depth)
(cl-find-if (lambda (node) (= (alist-get 'depth node)
(alist-get 'depth current-node)))
(cdr outline)))
(t (error "Unknown depth-req")))))
(defun my-pdf-view-forward-node ()
(interactive)
(let ((outline (pdf-info-outline (current-buffer))))
(if (not outline) (message "PDF has no outline")
(my-pdf-jump-and-set-current-node
(if (and my-pdf-view-current-node
(memq last-command my-pdf-view-navigation-functions))
(my-pdf-view-next-node-by-node my-pdf-view-current-node outline)
(my-pdf-view-next-node-by-page outline))))))
(defun my-pdf-view-lowest-node-current-page (outline)
"returns the last node of the lowest depth on the current page"
(let ((result) (current-page (pdf-view-current-page)))
(catch 'ret
(while outline
(let ((node (car outline)))
(cond ((= (alist-get 'page node) current-page)
(when (or (not result)
(<= (alist-get 'depth node)
(alist-get 'depth result)))
(setq result node)))
((> (alist-get 'page node) current-page)
(throw 'ret result))))
(setq outline (cdr outline))))))
(defun my-pdf-view-highest-node-current-page (outline)
"returns the first node of the highest depth on the current page"
(let ((result) (current-page (pdf-view-current-page)))
(catch 'ret
(while outline
(let ((node (car outline)))
(cond ((= (alist-get 'page node) current-page)
(when (or (not result)
(> (alist-get 'depth node)
(alist-get 'depth result)))
(setq result node)))
((> (alist-get 'page node) current-page)
(throw 'ret result))))
(setq outline (cdr outline))))))
(defun my-pdf-view-forward-node-same-depth ()
(interactive)
(let ((outline (pdf-info-outline (current-buffer))))
(if (not outline) (message "PDF has no outline")
(my-pdf-jump-and-set-current-node
(my-pdf-view-next-node-by-node
(if (and my-pdf-view-current-node
(memq last-command my-pdf-view-navigation-functions))
my-pdf-view-current-node
(my-pdf-view-lowest-node-current-page outline))
outline 'same-depth)))))
(defun my-pdf-view-prev-node-by-node (current-node outline &optional depth-req)
(let ((prev-node) (depth (alist-get 'depth current-node)))
(catch 'ret
(dolist (node outline)
(if (equal node current-node)
(throw 'ret prev-node)
(when (or (not depth-req)
(and (eq depth-req 'same-depth)
(eq (alist-get 'depth node) depth))
(and (eq depth-req 'lower-depth)
(< (alist-get 'depth node) depth)))
(setq prev-node node)))))))
(defun my-pdf-view-prev-node-by-page (outline)
(let ((prev-node))
(catch 'ret
(dolist (node outline)
(if (>= (alist-get 'page node) (pdf-view-current-page))
(throw 'ret prev-node)
(setq prev-node node))))))
(defun my-pdf-view-backward-node ()
(interactive)
(let ((outline (pdf-info-outline (current-buffer))))
(if (not outline) (message "PDF has no outline")
(my-pdf-jump-and-set-current-node
(if (and my-pdf-view-current-node
(memq last-command my-pdf-view-navigation-functions))
(my-pdf-view-prev-node-by-node my-pdf-view-current-node outline)
(my-pdf-view-prev-node-by-page outline))))))
(defun my-pdf-view-backward-node-same-depth ()
(interactive)
(let ((outline (pdf-info-outline (current-buffer))))
(if (not outline) (message "PDF has no outline")
(my-pdf-jump-and-set-current-node
(my-pdf-view-prev-node-by-node
(if (and my-pdf-view-current-node
(memq last-command my-pdf-view-navigation-functions))
my-pdf-view-current-node
(my-pdf-view-lowest-node-current-page outline))
outline 'same-depth)))))
(defun my-pdf-view-backward-node-lower-depth ()
(interactive)
(let ((outline (pdf-info-outline (current-buffer))))
(if (not outline) (message "PDF has no outline")
(my-pdf-jump-and-set-current-node
(my-pdf-view-prev-node-by-node
(if (and my-pdf-view-current-node
(memq last-command my-pdf-view-navigation-functions))
my-pdf-view-current-node
(my-pdf-view-lowest-node-current-page outline))
outline 'lower-depth)))))
(defun my-pdf-view-enlarge-a-bit () (interactive) (pdf-view-enlarge 1.01))
(defun my-pdf-view-shrink-a-bit () (interactive) (pdf-view-enlarge .99))
(defvar my-pdf-dptrp1-ip nil
"IP address of digital paper device for dpt-rp1 to connect to.")
(defvar my-pdf-dptrp1-program "dptrp1" "The name of the dpt-rp1 program.")
(defun my-pdf-dptrp1-upload (dest)
(interactive (list (read-string "[dptrp1] Upload to: " "Document/")))
(let ((file (buffer-file-name)))
(with-temp-buffer
(if (= (call-process my-pdf-dptrp1-program nil (current-buffer) nil
"--addr" my-pdf-dptrp1-ip "upload" file dest)
0)
(message "Uploaded %s to %s" file dest)
(message "Failed to upload %s to %s: %s" file dest (buffer-string))))))
(provide 'my-pdf-tools)
;;; my-pdf-tools.el ends here