diff --git a/docs/src/content/docs/dev/BUILDinDocker.md b/docs/src/content/docs/dev/BUILDinDocker.md index 918ab548..5bf2dd38 100644 --- a/docs/src/content/docs/dev/BUILDinDocker.md +++ b/docs/src/content/docs/dev/BUILDinDocker.md @@ -104,10 +104,10 @@ su - archer 之后每次从宿主机进入此 docker 环境，可使用以下命令： ```bash -sudo docker exec -it -u archer -w /home/archer arch /bin/bash -# 或者 sudo docker exec -it -u archer -w /home/archer/arCNiso arch /bin/bash ``` +这指定了在容器内的工作目录为 `/home/archer/arCNiso`，可按需调整。 + 余下步骤参见[构建说明](/dev/build)（直接在 docker 环境中执行相应操作即可）。 而在得到生成的镜像文件之后，可以使用 `docker cp` 等方法将其取出容器 diff --git a/homebase/public/.emacs.d/.gitignore b/homebase/public/.emacs.d/.gitignore new file mode 100644 index 00000000..fc33d73d --- /dev/null +++ b/homebase/public/.emacs.d/.gitignore @@ -0,0 +1,14 @@ +/auto-save-list +/cache +/eln-cache +/elpa +/transient +/tramp +/recentf +/.autosaves/* +/.org-id-locations + +/dirvish + +/init.*.el +/early-init.el diff --git a/homebase/public/.emacs.d/init.0.org b/homebase/public/.emacs.d/init.0.org new file mode 100644 index 00000000..4a36a8b6 --- /dev/null +++ b/homebase/public/.emacs.d/init.0.org @@ -0,0 +1,772 @@ +#+TITLE: Emacs 配置文件 +#+AUTHOR: Celestial.y +#+PROPERTY: header-args :tangle yes + +# STARTUP: overview + +* 序 +这是 arCNiso 默认的 Emacs 配置，采用 Org-mode 加 tangle 的方式组织而成。 + +** 致谢 +- Lars Tveito，本配置部分借鉴了[[https://github.com/larstvei/dot-emacs][其 Emacs 配置]]。 +- Emacs 社区，提供了分布于 Emacs China、EmacsWiki、GitHub 等地方的关于 Emacs 的大量资料。 + +** 使用 +在每次修改 =init.0.org= 之后，应当按 =C-c C-v t= 来 tangle 此文件。 + +此文件的顶部已经有了 =#+PROPERTY: header-args :tangle yes= ， +因此各代码块默认会被 tangle，除非加 =:tangle no= 。 + +用 =:tangle = 指定 tangle 的目标文件。 +- 若不指定，则目标默认为与本文件文件名相同、扩展名不同的文件。 +- 可指定绝对或相对路径；若指定相对路径，则它相对于本文件所在目录。 + +** init.el +*** 初始化 +当 =init.0.el= 不存在时，进行 tangle 并重启 emacs。 + +#+begin_src emacs-lisp :tangle init.el +;;; -*- lexical-binding: t -*- +;;; This file is generated from init.0.org, do not edit manually. + +(unless (file-exists-p (concat user-emacs-directory "init.0.el")) + (progn + (require 'org) + (find-file (concat user-emacs-directory "init.0.org")) + (org-babel-tangle) + (restart-emacs) + )) +#+end_src + +*** 加载配置 +加载其他 elisp 文件。 + +#+begin_src emacs-lisp :tangle init.el +(setq custom-file (concat user-emacs-directory "custom.el")) + +; 在 init.0.el 之前加载 +(let ((init--1 (concat user-emacs-directory "init.-1.el")) + (init--2 (concat user-emacs-directory "init.-2.el")) + (init--3 (concat user-emacs-directory "init.-3.el"))) + (when (file-exists-p init--3) (load-file init--3)) + (when (file-exists-p init--2) (load-file init--2)) + (when (file-exists-p init--1) (load-file init--1))) + +; 在 init.0.el 之后加载 +(add-hook + 'after-init-hook + (lambda () + (let ((init-1 (concat user-emacs-directory "init.1.el")) + (init-2 (concat user-emacs-directory "init.2.el")) + (init-3 (concat user-emacs-directory "init.3.el")) + (private-file (concat user-emacs-directory "private.el"))) + (when (file-exists-p init-1) (load-file init-1)) + (when (file-exists-p init-2) (load-file init-2)) + (when (file-exists-p init-3) (load-file init-3)) + (when (file-exists-p private-file) (load-file private-file)) + (when (and custom-file (file-exists-p custom-file)) (load-file custom-file)) + ; (server-start) + ))) + +; 加载 init.0.el +(load-file (concat user-emacs-directory "init.0.el")) +#+end_src + +*** 自动 tangle +为了避免每次发生变化都要手动 tangle， +可以限定对本文件自定义一个函数加到 =after-save-hook=​， +确保在 =org= 文件发生变化后总是 tangle 它。 + +当然，以下配置决定了仅在 =user-emacs-directory= 与本文件所在目录相同时才会有用。 + +#+begin_src emacs-lisp :tangle init.el + (defun tangle-for-init () + "Tangle all blocks." + ;; Avoid running hooks when tangling. + (let ((prog-mode-hook nil)) + (org-babel-tangle) + )) + + ; 仅当本文件是 Emacs 配置目录下的 init.0.org 时，才添加到 after-save-hook + (add-hook + 'org-mode-hook + (lambda () + (when + (equal + (buffer-file-name) + (expand-file-name + (concat + user-emacs-directory + "init.0.org"))) + (add-hook + 'after-save-hook + 'tangle-for-init + nil t)))) +#+end_src + + +* 初始设置 +** lexical scoping +至于什么是 lexical scoping，参见[[https://www.emacswiki.org/emacs/DynamicBindingVsLexicalBinding][这里]]。 + +#+begin_src emacs-lisp :tangle init.-3.el +;;; -*- lexical-binding: t -*- +#+end_src +#+begin_src emacs-lisp :tangle init.-2.el +;;; -*- lexical-binding: t -*- +#+end_src +#+begin_src emacs-lisp :tangle init.-1.el +;;; -*- lexical-binding: t -*- +#+end_src +#+begin_src emacs-lisp +;;; -*- lexical-binding: t -*- +#+end_src +#+begin_src emacs-lisp :tangle init.1.el +;;; -*- lexical-binding: t -*- +#+end_src +#+begin_src emacs-lisp :tangle init.2.el +;;; -*- lexical-binding: t -*- +#+end_src +#+begin_src emacs-lisp :tangle init.3.el +;;; -*- lexical-binding: t -*- +#+end_src + +* 性能优化 +** GC +在配置文件开头，提升 GC（garbage collection）的阈值 ~gc-cons-threshold~ +到一个非常大的值（默认是 800 kB）以降低触发 GC 的频率， +从而缩短启动时间。 + +在配置末尾（通过 =emacs-startup-hook= 或 =after-init-hook=​）再降回来。 + +#+begin_src emacs-lisp :tangle early-init.el +(setq gc-cons-threshold most-positive-fixnum) +(add-hook 'emacs-startup-hook + (lambda () + (setq gc-cons-threshold (* 100 1024 1024)))) +#+end_src + +注：这里利用了乘法命令来换算单位，例如 =(* 20 1024 1024)= 就是 20 MiB。 + +** 禁用 compile +Native compile 提升的性能并不明显，反而可能有负作用。 + +#+begin_src emacs-lisp :tangle early-init.el + (setq native-comp-speed -1) + (setq-default no-native-compile t) + (setq comp-deferred-compilation nil) +#+end_src + +** 禁用 bidi +参见： https://emacs-china.org/t/topic/25811/8 + +这可以优化超大规模文件的编辑性能。 +部分滥用 bidi 的插件可能无法正常工作，对这些插件单独启用 bidi 即可。 + +#+begin_src emacs-lisp +(setq-default bidi-display-reordering nil) +(setq bidi-inhibit-bpa t + long-line-threshold 1000 + large-hscroll-threshold 1000 + syntax-wholeline-max 1000) +#+end_src + +** 启动时间检测 +提示：可运行此命令来测试理论上的最短启动时间： +#+begin_src bash :tangle no +emacs -q --eval='(message "%s" (emacs-init-time))' +#+end_src +其中 =-q= 忽略用户 emacs 文件但加载 site 文件。 + +加入时间检测： +#+begin_src emacs-lisp + (add-hook 'emacs-startup-hook + (lambda () + (message "Emacs ready in %s with %d garbage collections." + (format "%.2f seconds" + (float-time + (time-subtract after-init-time before-init-time))) + gcs-done))) +#+end_src + +esup 能分析出更详细的信息。 +参见： https://github.com/jschaf/esup + +#+begin_src emacs-lisp +(use-package esup + :ensure t + :pin melpa) +(autoload 'esup "esup" "Emacs Start Up Profiler." nil) +#+end_src + + +* 插件加载与包管理 +** use-package +[[https://lists.gnu.org/archive/html/emacs-devel/2022-12/msg00261.html][自 Emacs 29]]，[[https://github.com/jwiegley/use-package][use-package]] 成为内置的包。 + +#+begin_src emacs-lisp :tangle init.-2.el +(require 'package) ; 加载 package.el +(require 'use-package) +(setq use-package-always-ensure t) +(setq package-check-signature nil) ; 是否检查签名 +#+end_src +** 仓库 +注意，由于 Emacs 的 bug，URL 末尾必须为 =/=​。 + +- gnu：一般是必备的，其它的 elpa 中的包会依赖 gnu 中的包。 +- nongnu：建议启用，类似于 melpa 但是 Emacs 官方维护的。 +- melpa：滚动升级，收录了的包的数量最大。 +- stable-melpa：依据源码的 Tag （Git）升级，数量比 melpa 少，因为很多包作者根本不打 Tag。 + - 也有部分作者即使打了 Tag 也不推荐使用 stable-melpa。 +- org：仅仅为了 org-plus-contrib 这一个包，供 org-mode 重度用户使用 +- gnu-devel：收录 gnu 中的包的开发中版本，一般不必启用（与 gnu 的关系类似于 melpa 与 stable-melpa 的关系） +- nongnu-devel：收录 nongnu 中的包的开发中版本，一般不必启用 + +参考配置： +#+begin_src emacs-lisp :tangle no +(setq package-archives + '(("GNU ELPA" . "https://elpa.gnu.org/packages/") + ("MELPA Stable" . "https://stable.melpa.org/packages/") + ("MELPA" . "https://melpa.org/packages/"))) +#+end_src + +不过这里我们采用镜像源： +#+begin_src emacs-lisp :tangle init.-2.el +(setq package-archives '(("gnu" . "https://mirrors.cernet.edu.cn/elpa/gnu/") + ("nongnu" . "http://mirrors.cernet.edu.cn/elpa/nongnu/") + ("melpa-stable" . "http://mirrors.tuna.tsinghua.edu.cn/elpa/stable-melpa/") + ("melpa" . "https://mirrors.cernet.edu.cn/elpa/melpa/") + ("nongnu" . "https://mirrors.cernet.edu.cn/elpa/nongnu/"))) +#+end_src + +最后再配置优先级： +#+begin_src emacs-lisp :tangle init.-2.el +(setq package-archive-priorities + '(("gnu" . 10) + ("nongnu" . 7) + ("melpa" . 5) + ("melpa-stable" . 0))) +#+end_src + +其他配置： +#+begin_src emacs-lisp :tangle no +; 自动安装所有使用 use-package 声明的插件 +(require 'use-package-ensure) +(setq use-package-always-ensure t) +#+end_src + +未启用的配置： +#+begin_src emacs-lisp :tangle no +; 刷新插件列表 +(unless package-archive-contents (package-refresh-contents)) +(use-package quelpa + :ensure t + :commands quelpa + :custom + (quelpa-git-clone-depth 1) + (quelpa-self-upgrade-p nil) + (quelpa-update-melpa-p nil) + (quelpa-checkout-melpa-p nil)) +#+end_src + +** 其他包的加载 +直接用 =load-path= 可以指定 Emacs 在哪里寻找 Elisp 即 =*.el= 文件，但以下要做到递归。 + +这里借鉴懒猫的实现。 +参见 https://manateelazycat.github.io/2022/03/02/emacs-load-directory-recursively/ + +#+begin_src emacs-lisp :tangle init.-2.el :hidden t + (defun add-subdirs-to-load-path (search-dir) + (interactive) + (require 'cl-lib) + (let* ((dir (file-name-as-directory search-dir))) + (dolist (subdir + ;; 过滤出不必要的目录， 提升 Emacs 启动速度 + (cl-remove-if + #'(lambda (subdir) + (or + ;; 不是目录的都移除 + (not (file-directory-p (concat dir subdir))) + ;; 目录匹配下面规则的都移除 + (member subdir '("." ".." ;Linux 当前目录和父目录 + "dist" "node_modules" "__pycache__" ;语言相关的模块目录 + "RCS" "CVS" "rcs" "cvs" ".git" ".github")))) ;版本控制目录 + (directory-files dir))) + (let ((subdir-path (concat dir (file-name-as-directory subdir)))) + ;; 目录下有 .el .so .dll 文件的路径才添加到 load-path 中， 提升 Emacs 启动速度 + (when (cl-some #'(lambda (subdir-file) + (and (file-regular-p (concat subdir-path subdir-file)) + ;; .so .dll 文件指非 Elisp 语言编写的 Emacs 动态库 + (member (file-name-extension subdir-file) '("el" "so" "dll")))) + (directory-files subdir-path)) + + ;; 注意： add-to-list 函数的第三个参数必须为 t ， 表示加到列表末尾 + ;; 这样 Emacs 会从父目录到子目录的顺序搜索 Elisp 插件， 顺序反过来会导致 Emacs 无法正常启动 + (add-to-list 'load-path subdir-path t)) + + ;; 继续递归搜索子目录 + (add-subdirs-to-load-path subdir-path))))) + + (add-subdirs-to-load-path (concat user-emacs-directory "locext/")) +#+end_src + +* 一些合理的默认设置 +- Q: 为什么有时要 =setq-default= 而不是 =setq= ？ +- A: 有一些变量是缓冲区局部（buffer-local）的， + 所以用 =setq= 来设置它们的值仅能在单个缓冲区改变它们， + 而应当使用 =setq-default= 来配置它们的默认值。 +** 编码 + +#+begin_src emacs-lisp +(set-language-environment "UTF-8") +(set-default-coding-systems 'utf-8) +(set-buffer-file-coding-system 'utf-8-unix) +(set-clipboard-coding-system 'utf-8-unix) +(set-file-name-coding-system 'utf-8-unix) +(set-keyboard-coding-system 'utf-8-unix) +(set-next-selection-coding-system 'utf-8-unix) +(set-selection-coding-system 'utf-8-unix) +(set-terminal-coding-system 'utf-8-unix) +(setq locale-coding-system 'utf-8) +(prefer-coding-system 'utf-8) +#+end_src + +** 自动保存与备份 +确保自动保存与备份的文件都放在同一个目录下。 +#+begin_src emacs-lisp + (setq backup-by-copying t ; 自动备份 + delete-old-versions t ; 自动删除旧的备份文件 + kept-new-versions 6 ; 保留最近备份文件数量 + kept-old-versions 2 ; 保留最早备份文件数量 + version-control t) ; 多次备份 + ; 路径位置 + (defvar emacs-autosave-directory + (concat user-emacs-directory ".autosaves/") + "This variable dictates where to put auto saves.") + (setq + ; 自动备份的路径位置 + backup-directory-alist + `((".*" . ,emacs-autosave-directory)) + ; 自动保存的路径位置 + auto-save-file-name-transforms + `((".*" ,emacs-autosave-directory t))) +#+end_src + +** 启动界面 +#+begin_src emacs-lisp + (setq + inhibit-startup-screen t ; 防止在外部调用 emacs 打开文件时，一半界面用来显示欢迎界面 + initial-scratch-message nil ; 清空新的 scratch 缓冲区 +) +#+end_src + +** isearch-mb +主要用来增强 isearch，以解决 emacs-rime 无法在 isearch 中使用的问题。 + +- Q: 为什么不用 evil-search？ +- A: 因为只有 isearch 能搜到 org-mode 中被折叠的部分，见 https://github.com/emacs-evil/evil/issues/1630 + +#+begin_src emacs-lisp + (load (concat user-emacs-directory "locext/isearch-mb/isearch-mb.el")) + (add-hook 'org-mode-hook 'isearch-mb-mode) +#+end_src + +** 其他 +用单字母 =y= =n= 而不是 =yes= 和 =no= 来回答。 +#+begin_src emacs-lisp +(fset 'yes-or-no-p 'y-or-n-p) +#+end_src + +为 =doc-view-mode= 启用 =auto-revert-mode=​。[fn::auto-revert 即，当磁盘上的文件变化时，自动反向同步到缓冲区。] +#+begin_src emacs-lisp +(add-hook 'doc-view-mode-hook 'auto-revert-mode) +#+end_src + +其他一些未启用的示例： +#+begin_src emacs-lisp :tangle no :hidden t + (setq + auto-revert-interval 1 ; Refresh buffers fast + default-input-method "TeX" ; Use TeX when toggling input method + echo-keystrokes 0.1 ; Show keystrokes asap + enable-recursive-minibuffers t ; Allow recursive minibuffers + frame-inhibit-implied-resize 1 ; Don't resize frame implicitly + recentf-max-saved-items 10000 ; Show more recent files + ring-bell-function 'ignore ; Quiet + sentence-end-double-space nil ; 默认值 t 的行为：单空格不会结束一个句子。受影响的函数是 sentence-end，被用于正则匹配。 + ) + (setq-default + fill-column 79 ; Maximum line width + split-width-threshold 160 ; Split verticly by default + split-height-threshold nil ; Split verticly by default + frame-resize-pixelwise t ; Fine-grained frame resize + auto-fill-function 'do-auto-fill ; Auto-fill-mode everywhere + ) +#+end_src + +* 按键绑定 +** 自定义 map 与 mode +参见： [[http://stackoverflow.com/questions/683425/globally-override-key-binding-in-emacs][StackOverflow]] + +自定义一个 =custom-bindings-map= 来存放所有的自定义按键绑定。 +这样做有很多好处，比如只要禁要这个 map，别人就能直接使用你的 Emacs。 + +#+begin_src emacs-lisp :tangle init.-1.el +(defvar custom-bindings-map (make-keymap) + "A keymap for custom bindings.") +#+end_src + +只需要切换辅模式就能切换启用这个 map。 +为了防止其他主模式覆盖这些绑定，这里放在最后加载。 + +#+begin_src emacs-lisp :tangle init.3.el +(define-minor-mode custom-bindings-mode + "A mode that activates custom-bindings." + :init-value t + :keymap custom-bindings-map) +#+end_src + +** Evil + +#+begin_src emacs-lisp +(setq evil-undo-system 'undo-redo) ;须先设置，再加载 evil +(setq evil-search-module 'isearch) ;如果不设置这个，在切换输入法时搜索栏会消失 +(setq evil-want-keybinding nil) +(setq evil-want-keybindings nil) +(use-package evil) +(use-package evil-collection) +; 不加 require 会报 warning，要求先设置 evil-want-keybinding 为 nil，即使已经这么设了 +(require 'evil) +(require 'evil-collection) +(evil-mode 1) +(evil-collection-init) +;(define-key evil-insert-state-map (kbd "C-n") nil) +;(define-key evil-insert-state-map (kbd "C-p") nil) + +(define-key evil-normal-state-map (kbd "C-=") #'text-scale-adjust) +(define-key evil-normal-state-map (kbd "C--") #'text-scale-adjust) +#+end_src + +*** evil-tutor-sc +简体中文的 evil 实践式教程。 +#+begin_src emacs-lisp :tangle no + (use-package evil-tutor-sc) +#+end_src + +* 外观 + +** 减法 +#+begin_src emacs-lisp :tangle early-init.el + ; 禁用一些辅模式 + (dolist (mode + '(tool-bar-mode ; 工具栏 +; menu-bar-mode ; 菜单栏 + scroll-bar-mode ; 滚动栏 + blink-cursor-mode ; 闪烁光标 + )) (funcall mode 0)) +#+end_src + +** 主题 +#+begin_src emacs-lisp +(use-package nord-theme) +#+end_src + +简单加载，但不适用于 Emacs daemon 模式 +#+begin_src emacs-lisp :tangle no +(add-hook 'after-init-hook (lambda () + (load-theme 'nord t) +)) +#+end_src + +适用于 Emacs daemon 模式，但似乎可能会有问题。 +#+begin_src emacs-lisp +(if (daemonp) + (cl-labels ((load-nord (frame) + (with-selected-frame frame + (load-theme 'nord t)) + (remove-hook 'after-make-frame-functions #'load-nord))) + (add-hook 'after-make-frame-functions #'load-nord)) + (load-theme 'nord t)) +#+end_src + +适用于 Emacs daemon 模式，但注意不适用于终端，见 https://github.com/nordtheme/emacs/issues/59#issuecomment-611610832 +#+begin_src emacs-lisp :hidden t :tangle no +(defvar my:theme 'nord) +(defvar my:theme-window-loaded nil) +(defvar my:theme-terminal-loaded nil) + +(if (daemonp) + (add-hook 'after-make-frame-functions(lambda (frame) + (select-frame frame) + (if (window-system frame) + (unless my:theme-window-loaded + (if my:theme-terminal-loaded + (enable-theme my:theme) + (load-theme my:theme t)) + (setq my:theme-window-loaded t) + ) + (unless my:theme-terminal-loaded + (if my:theme-window-loaded + (enable-theme my:theme) + (load-theme my:theme t)) + (setq my:theme-terminal-loaded t) + ) + ))) + + (progn + (load-theme my:theme t) + (if (display-graphic-p) + (setq my:theme-window-loaded t) + (setq my:theme-terminal-loaded t))) + ) +#+end_src + +另一种方案是在启动 emacsclient 的参数里加 =--eval "(load-theme 'nord t)"=​，但这可能会降低 Emacs 启动速度。 + +与主题相适应的一些外观调整： +#+begin_src emacs-lisp :tangle early-init.el + ; 菜单栏配色 + (set-face-attribute 'menu nil + :inverse-video nil + :background "black" + :foreground "white" + :bold t) + ; 背景透明 + (add-to-list 'default-frame-alist '(alpha-background . 60)) +#+end_src + +** 自动折行（换行） +#+begin_src emacs-lisp +(setq-default truncate-lines nil) +(add-hook 'org-mode-hook + (lambda() + (setq truncate-lines nil))) +#+end_src + +** 字体 +#+begin_src emacs-lisp +;(add-to-list 'default-frame-alist '(font . "LXGW WenKai Mono-20")) +(set-face-attribute 'default t :font "LXGW WenKai Mono-20") +#+end_src + +** 行号栏 +#+begin_src emacs-lisp :tangle early-init.el +(global-display-line-numbers-mode 1) +(setq display-line-numbers-type 'relative) +(setq display-line-numbers-current-absolute t) +; 防止因为行号位数不同，导致光标上下移动时界面左右晃动 +(setq display-line-numbers-grow-only t) +;(setq display-line-numbers-width 4) +#+end_src + +** 滚动 +#+begin_src emacs-lisp + ;(add-to-list 'load-path (concat user-emacs-directory "locext/good-scroll.el")) + (load (concat user-emacs-directory "locext/good-scroll.el/good-scroll.el")) + (good-scroll-mode 1) + (global-set-key (kbd "") #'good-scroll-up-full-screen) + (global-set-key (kbd "") #'good-scroll-down-full-screen) + + (load (concat user-emacs-directory "locext/iscroll/iscroll.el")) + (iscroll-mode 1) + ;(setq scroll-margin 5) ; 光标与窗口上下边缘的距离 + ;https://github.com/casouri/iscroll +#+end_src + +** 复制粘贴、鼠标、菜单 +#+begin_src emacs-lisp +(context-menu-mode 1) +(use-package xclip) +(xclip-mode 1) +(setq select-enable-clipboard t) +(use-package evil-terminal-cursor-changer) +(unless (display-graphic-p) + (require 'evil-terminal-cursor-changer) + (evil-terminal-cursor-changer-activate) ; or (etcc-on) + (xterm-mouse-mode 1) + ) +#+end_src + +** 缩进 +#+begin_src emacs-lisp +(setq-default tab-width 2) ;; 一个 tab 的字符宽 +(setq-default indent-tabs-mode nil) ;; 是否使用真实的 tab（否则替换成空格） +#+end_src + +** 折叠 +#+begin_src emacs-lisp +(use-package folding) + +(if (require 'folding nil 'noerror) + (folding-mode-add-find-file-hook) + (message "Library `folding' not found")) +(folding-add-to-marks-list 'emacs-lisp-mode ";;{{{" ";;}}}") (add-hook 'emacs-lisp-mode-hook #'folding-mode) +(folding-add-to-marks-list 'shell-script-mode "# {{{" "# }}}") (add-hook 'shell-script-mode-hook #'folding-mode) +(folding-add-to-marks-list 'org-mode "# {{{" "# }}}") (add-hook 'org-mode-hook #'folding-mode) + +(define-key evil-normal-state-map "za" #'folding-toggle-show-hide) + +#+end_src + +** 辅助信息 +#+begin_src emacs-lisp +(use-package which-key + :custom (which-key-idle-delay 0.5) ; 延迟时间, 以秒为单位 + :config (which-key-mode)) ; 启用 which-key 模式 + +; keycast 可能有点问题，再观察看看 +(use-package keycast + :config (keycast-header-line-mode 1)) ; 是否在标题显示 + +(use-package helpful + :bind + ;; 将原本帮助系统的键位分配给 helpful + (([remap describe-function] . #'helpful-callable) + ([remap describe-variable] . #'helpful-variable) + ([remap describe-key] . #'helpful-key) + ([remap describe-command] . #'helpful-command) + ([remap describe-symbol] . #'helpful-symbol) + ; 新增两种帮助 + ("C-h C-d" . #'helpful-at-point) + ("C-h F" . #'helpful-function))) + +(use-package marginalia ; 更多信息 + :config (marginalia-mode)) + +; 注意orderless这个插件可能与ivy冲突，使得在minibuffer里用tab补全（比如路径）时无法正常进行。 +(use-package ivy + :ensure t + :diminish ivy-mode + :hook (after-init . ivy-mode)) +#+end_src + + +** 其他 +#+begin_src emacs-lisp +(setq-default line-spacing 2) ; 行距 +#+end_src + +* Org 与 LaTeX +** org-mode +#+begin_src emacs-lisp :tangle init.-3.el +(require 'org) +#+end_src + +** Evil-org +#+begin_src emacs-lisp +;; evil-org +(use-package evil-org + :ensure t + :after org + :hook (org-mode . (lambda () evil-org-mode))) +(setq evil-want-C-i-jump nil) +#+end_src + +** valign表格对齐 +- https://github.com/casouri/valign +- https://github.com/casouri/ftable +#+begin_src emacs-lisp + (load (concat user-emacs-directory "locext/valign/valign.el")) + (require 'valign) + (load (concat user-emacs-directory "locext/ftable/ftable.el")) + (require 'ftable) + (add-hook 'org-mode-hook #'valign-mode) + + (setq valign-fancy-bar t) +#+end_src + +** Org 自动换行 +#+begin_src emacs-lisp +(defun org-line-wrap () + "org mode's line wrap automatically." + (setq-local word-wrap nil)) +(add-hook 'org-mode-hook 'org-line-wrap) +#+end_src + +** 自动编号 +#+begin_src emacs-lisp +(add-hook 'org-mode-hook 'org-num-mode) +; 是否跳过UNNUMBERED的编号 +(setq org-num-skip-unnumbered t) +#+end_src + +** 其他外观 +注：org-pretty-entities 会导致下划线几乎一律隐藏并显示为下标， +即使它实际上并不是下标（比如，作为 PROPERTIES 中属性的键会正常显示，而作为值时就会显示为下标）。 +#+begin_src emacs-lisp +(setq-default org-startup-indented t + org-pretty-entities nil + org-hide-emphasis-markers nil) +#+end_src + +** org-modern +#+begin_src emacs-lisp +(load (concat user-emacs-directory "locext/org-modern/org-modern.el")) +(require 'org-modern) +(add-hook 'org-mode-hook 'global-org-modern-mode) +(setq org-modern-block-name nil + org-modern-keyword nil + org-modern-checkbox nil + org-modern-table nil) +#+end_src + +** faces +设置Org mode标题以及每级标题行的大小 +以及 block 的上下沿、背景色 +#+begin_src emacs-lisp +(custom-set-faces + '(org-document-title ((t (:height 1.75 :weight bold)))) + '(org-level-1 ((t (:height 1.2 :weight bold)))) + '(org-level-2 ((t (:height 1.15 :weight bold)))) + '(org-level-3 ((t (:height 1.1 :weight bold)))) + '(org-level-4 ((t (:height 1.05 :weight bold)))) + '(org-level-5 ((t (:height 1.0 :weight bold)))) + '(org-level-6 ((t (:height 1.0 :weight bold)))) + '(org-level-7 ((t (:height 1.0 :weight bold)))) + '(org-level-8 ((t (:height 1.0 :weight bold)))) + '(org-level-9 ((t (:height 1.0 :weight bold)))) + '(org-block ((t (:background "rgba(0, 0, 0, 0.5)")))) + '(org-block-begin-line ((t (:underline nil :background "rgba(30, 40, 50, 0.2)")))) + '(org-block-end-line ((t (:overline nil :underline nil :background "rgba(30, 40, 50, 0.2)"))))) + +(setq org-fontify-whole-heading-line t) +(setq org-fontify-quote-and-verse-blocks t) +#+end_src + +** org 插入图片 +#+begin_src emacs-lisp +(add-hook 'org-mode-hook 'org-display-inline-images) +(setq org-image-actual-width '(900)) +#+end_src + +** 其他 +支持代码块自动折叠 +用法：在 begin_src 后面加 :hidden t +https://emacs.stackexchange.com/questions/44914/choose-individual-startup-visibility-of-org-modes-source-blocks +#+begin_src emacs-lisp :hidden t + (defun individual-visibility-source-blocks () + "Fold some blocks in the current buffer." + (interactive) + (org-fold-show-all '(blocks)) + (org-block-map + (lambda () + (let ((case-fold-search t)) + (when (and + (save-excursion + (beginning-of-line 1) + (looking-at org-block-regexp)) + (cl-assoc + ':hidden + (cl-third + (org-babel-get-src-block-info)))) + (org-fold-hide-block-toggle)))))) + + (add-hook + 'org-mode-hook + (function individual-visibility-source-blocks)) +#+end_src + +* sudo edit +#+begin_src emacs-lisp +(use-package auto-sudoedit) +(auto-sudoedit-mode 1) +#+end_src diff --git a/homebase/public/.emacs.d/init.el b/homebase/public/.emacs.d/init.el index 8343fc24..f884c1d1 100644 --- a/homebase/public/.emacs.d/init.el +++ b/homebase/public/.emacs.d/init.el @@ -1,198 +1,62 @@ -;; -*- lexical-binding: t; -*- -;; vim:fileencoding=utf-8:ft=config:fdm=marker foldlevel=0 -;; Local Variables: -;; eval: (folding-mode) -;; End: - -;;{{{ 把 emacs 的 custom 放到 custom.el 中 - -(setq custom-file (expand-file-name "custom.el" user-emacs-directory)) - -;;}}} - -;;{{{ 插件仓库 - -(require 'package) ; 加载 package.el -(setq package-check-signature nil) ; 是否检查签名 -;; 添加仓库位置 -;; 注：由于emacs的bug，url末尾必须为 `/'。 -;; gnu 一般是必备的，其它的 elpa 中的包会依赖 gnu 中的包 -;; nongnu 建议启用，类似于 melpa 但是 Emacs 官方维护的 -;; melpa 滚动升级，收录了的包的数量最大 -;; stable-melpa 依据源码的 Tag （Git）升级，数量比 melpa 少，因为很多包作者根本不打 Tag -;; org 仅仅为了 org-plus-contrib 这一个包，org 重度用户使用 -;; gnu-devel 收录 gnu 中的包的开发中版本，一般不必启用（与 gnu 的关系类似于 melpa 与 stable-melpa 的关系） -;; nongnu-devel 收录 nongnu 中的包的开发中版本，一般不必启用 -(setq package-archives '(("gnu" . "https://mirrors.cernet.edu.cn/elpa/gnu/") - ("nongnu" . "http://mirrors.cernet.edu.cn/elpa/nongnu/") - ("melpa-stable" . "http://mirrors.tuna.tsinghua.edu.cn/elpa/stable-melpa/") - ("melpa" . "https://mirrors.cernet.edu.cn/elpa/melpa/") - ;("melpa" . "https://melpa.org/packages/") - ("nongnu" . "https://mirrors.cernet.edu.cn/elpa/nongnu/"))) -;; 刷新插件列表 -;(unless package-archive-contents (package-refresh-contents)) -;; 自动安装 use-package. 在Emacs 29中已内置故可省略 -;(unless (package-installed-p 'use-package) (package-install 'use-package)) -;; 自动安装所有使用 use-package 声明的插件 -(require 'use-package-ensure) -(setq use-package-always-ensure t) -;; QUELPA -;(use-package quelpa -; :ensure t -; :commands quelpa -; :custom -; (quelpa-git-clone-depth 1) -; (quelpa-self-upgrade-p nil) -; (quelpa-update-melpa-p nil) -; (quelpa-checkout-melpa-p nil)) -; -;;;}}} - -;;;{{{ 性能优化 -;; 在配置文件开头，提升gc(garbage collection)域值（默认是 800 kB），以降低gc频率来提升启动速度（在配置末尾再降回来） -(setq gc-cons-threshold (* 50 1000 1000)) -;;}}} - -;;{{{ 编码 - -(set-language-environment "UTF-8") -(set-default-coding-systems 'utf-8) -(set-buffer-file-coding-system 'utf-8-unix) -(set-clipboard-coding-system 'utf-8-unix) -(set-file-name-coding-system 'utf-8-unix) -(set-keyboard-coding-system 'utf-8-unix) -(set-next-selection-coding-system 'utf-8-unix) -(set-selection-coding-system 'utf-8-unix) -(set-terminal-coding-system 'utf-8-unix) -(setq locale-coding-system 'utf-8) -(prefer-coding-system 'utf-8) - -;;}}} - -;;{{{ Evil - -(setq evil-undo-system 'undo-redo) ;须先设置，再加载evil -(setq evil-search-module 'evil-search) -(setq evil-want-keybinding nil) -(setq evil-want-keybindings nil) -(use-package evil) -(use-package evil-collection) -; 不加require会报warning，要求先设置evil-want-keybinding为nil，即使已经这么设了 -(require 'evil) -(require 'evil-collection) -(evil-mode 1) -(evil-collection-init) -;(define-key evil-insert-state-map (kbd "C-n") nil) -;(define-key evil-insert-state-map (kbd "C-p") nil) -(use-package evil-tutor) -(use-package evil-tutor-sc) -;;}}} - -;;{{{ 外观 -(use-package nord-theme) -(load-theme 'nord t) -;(menu-bar-mode -1) -(tool-bar-mode -1) -(scroll-bar-mode -1) -(set-face-attribute 'menu nil - :inverse-video nil - :background "black" - :foreground "white" - :bold t) -(setq-default truncate-lines nil) -(add-hook 'org-mode-hook - (lambda() - (setq truncate-lines nil))) -;(add-to-list 'default-frame-alist '(font . "LXGW WenKai Mono-20")) -(set-face-attribute 'default t :font "LXGW WenKai Mono-20") -(define-key evil-normal-state-map (kbd "C-=") #'text-scale-adjust) -(define-key evil-normal-state-map (kbd "C--") #'text-scale-adjust) - -;;}}} - -;;{{{ 复制粘贴、鼠标、菜单 - -(context-menu-mode 1) -(use-package xclip) -(xclip-mode 1) -(setq x-select-enable-clipboard t) -(use-package evil-terminal-cursor-changer) -(unless (display-graphic-p) - (require 'evil-terminal-cursor-changer) - (evil-terminal-cursor-changer-activate) ; or (etcc-on) - (xterm-mouse-mode 1) - ) - -;;}}} - -;;{{{ 操作行为 - -(setq-default tab-width 2) ;; 一个 tab 的字符宽 -(setq-default indent-tabs-mode nil) ;; 是否使用真实的 tab（否则替换成空格） - -;;}}} - -;;{{{ 折叠 - -(use-package folding) - -(if (require 'folding nil 'noerror) - (folding-mode-add-find-file-hook) - (message "Library `folding' not found")) -(folding-add-to-marks-list 'emacs-lisp-mode ";;{{{" ";;}}}") (add-hook 'emacs-lisp-mode-hook #'folding-mode) -(folding-add-to-marks-list 'shell-script-mode "# {{{" "# }}}") (add-hook 'shell-script-mode-hook #'folding-mode) - -(define-key evil-normal-state-map "za" #'folding-toggle-show-hide) - -;;}}} - -;;{{{ 辅助信息 - -(use-package which-key - :custom (which-key-idle-delay 0.5) ; 延迟时间, 以秒为单位 - :config (which-key-mode)) ; 启用 which-key 模式 - -(use-package keycast - :config (keycast-header-line-mode 1)) ; 在标题显示 - -(use-package helpful - :bind - ;; 将原本帮助系统的键位分配给 helpful - (([remap describe-function] . #'helpful-callable) - ([remap describe-variable] . #'helpful-variable) - ([remap describe-key] . #'helpful-key) - ([remap describe-command] . #'helpful-command) - ([remap describe-symbol] . #'helpful-symbol) - ; 新增两种帮助 - ("C-h C-d" . #'helpful-at-point) - ("C-h F" . #'helpful-function))) - -(use-package marginalia ; 更多信息 - :config (marginalia-mode)) - -(use-package ivy - :ensure t - :diminish ivy-mode - :hook (after-init . ivy-mode)) -;;}}} - -;;{{{ tramp -(use-package auto-sudoedit) -(auto-sudoedit-mode 1) -;;}}} - -;;{{{ 自动备份 -(setq backup-by-copying t ; 自动备份 - backup-directory-alist `(("." . "~/.cache/backups/")) ; 自动备份目录 - auto-save-file-name-transforms `((".*" "~/.cache/autosaves/" t)) ; 自动保存目录，注意这个目录可能需要手动创建 - delete-old-versions t ; 自动删除旧的备份文件 - kept-new-versions 6 ; 保留最近的n个备份文件 - kept-old-versions 2 ; 保留最早的n个备份文件 - version-control t) ; 多次备份 -;;}}} - -;;{{{ 这段代码放在最后, 加载 Emacs 的 custom -(if (file-exists-p custom-file) (load-file custom-file)) -;; 降低gc域值，使 gc 更快地暂停 -(setq gc-cons-threshold (* 2 1000 1000)) -;;}}} +;;; -*- lexical-binding: t -*- +;;; This file is generated from init.0.org, do not edit manually. + +(unless (file-exists-p (concat user-emacs-directory "init.0.el")) + (progn + (require 'org) + (find-file (concat user-emacs-directory "init.0.org")) + (org-babel-tangle) + (restart-emacs) + )) + +(setq custom-file (concat user-emacs-directory "custom.el")) + +; 在 init.0.el 之前加载 +(let ((init--1 (concat user-emacs-directory "init.-1.el")) + (init--2 (concat user-emacs-directory "init.-2.el")) + (init--3 (concat user-emacs-directory "init.-3.el"))) + (when (file-exists-p init--3) (load-file init--3)) + (when (file-exists-p init--2) (load-file init--2)) + (when (file-exists-p init--1) (load-file init--1))) + +; 在 init.0.el 之后加载 +(add-hook + 'after-init-hook + (lambda () + (let ((init-1 (concat user-emacs-directory "init.1.el")) + (init-2 (concat user-emacs-directory "init.2.el")) + (init-3 (concat user-emacs-directory "init.3.el")) + (private-file (concat user-emacs-directory "private.el"))) + (when (file-exists-p init-1) (load-file init-1)) + (when (file-exists-p init-2) (load-file init-2)) + (when (file-exists-p init-3) (load-file init-3)) + (when (file-exists-p private-file) (load-file private-file)) + (when (and custom-file (file-exists-p custom-file)) (load-file custom-file)) + ; (server-start) + ))) + +; 加载 init.0.el +(load-file (concat user-emacs-directory "init.0.el")) + +(defun tangle-for-init () + "Tangle all blocks." + ;; Avoid running hooks when tangling. + (let ((prog-mode-hook nil)) + (org-babel-tangle) + )) + +; 仅当本文件是 Emacs 配置目录下的 init.0.org 时，才添加到 after-save-hook +(add-hook + 'org-mode-hook + (lambda () + (when + (equal + (buffer-file-name) + (expand-file-name + (concat + user-emacs-directory + "init.0.org"))) + (add-hook + 'after-save-hook + 'tangle-for-init + nil t)))) diff --git a/homebase/public/.emacs.d/locext/ftable/README.org b/homebase/public/.emacs.d/locext/ftable/README.org new file mode 100644 index 00000000..b2309092 --- /dev/null +++ b/homebase/public/.emacs.d/locext/ftable/README.org @@ -0,0 +1,25 @@ +#+TITLE: ftable.el + +[[https://elpa.gnu.org/packages/ftable.html][https://elpa.gnu.org/packages/ftable.svg]] + +This package provides some convenient commands for filling a table, i.e., adjusting the layout of the table so it can fit in n columns. + +[[./ftable.gif]] + +Commands provided: + +- ftable-fill :: Fill the table at point +- ftable-reformat :: Change the style of the table. For example, from +#+begin_example + ASCII +--+--+ to Unicode ┌──┬──┐ + | | | │ │ │ + +--+--+ └──┴──┘ +#+end_example + +- ftable-edit-cell :: Edit the cell at point + +There are some limitations. Currently ftable doesn’t support tables with compound cells (cells that span multiple rows/columns) because they are more complicated to handle. If the need arises in the future (unlikely), I might improve ftable to handle more complex tables. Also, after filling, any manual line-break in a cell is discarded. + +* Customization + +- ftable-fill-column :: ~fill-column~ for ftable. diff --git a/homebase/public/.emacs.d/locext/ftable/ftable.el b/homebase/public/.emacs.d/locext/ftable/ftable.el new file mode 100644 index 00000000..4f693d9c --- /dev/null +++ b/homebase/public/.emacs.d/locext/ftable/ftable.el @@ -0,0 +1,726 @@ +;;; ftable.el --- Fill a table to fit in n columns -*- lexical-binding: t; -*- + +;; Copyright (C) 2019-2021 Free Software Foundation, Inc. + +;; Author: Yuan Fu +;; Maintainer: Yuan Fu +;; URL: https://github.com/casouri/ftable +;; Version: 1.1 +;; Keywords: convenience, text, table +;; Package-Requires: ((emacs "26.0")) + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; This package provides some convenient commands for filling a table, +;; i.e., adjusting the layout of the table so it can fit in n columns. +;; +;; Commands provided: +;; +;; - ftable-fill Fill the table at point +;; - ftable-reformat Change the style of the table. For example, from +;; ASCII +--+--+ to Unicode ┌──┬──┐ +;; | | | │ │ │ +;; +--+--+ └──┴──┘ +;; - ftable-edit-cell Edit the cell at point +;; +;; There are some limitations. Currently ftable doesn’t support tables +;; with compound cells (cells that span multiple rows/columns) because +;; they are more complicated to handle. If the need arises in the +;; future (unlikely), I might improve ftable to handle more complex +;; tables. Also, after filling, any manual line-break in a cell is +;; discarded. +;; +;; Customization: +;; +;; - ftable-fill-column + +;;; Code: + +(require 'cl-lib) +(require 'cl-generic) +(require 'pcase) +;; (require 'fill) fill.el doesn’t have a provide form. + +;;; Customization + +(defgroup ftable nil + "Fill (auto-layout) tables." + :group 'text) + +(defcustom ftable-fill-column fill-column + "Basically `fill-column' for ftable." + :local t + :type 'number) + +;; KLUDGE: There seems to be a bug preventing ftable-fill-column to be +;; set. (#44911) +(setq ftable-fill-column fill-column) + +;;; Table structure + +(cl-defstruct ftable + "A table. + +COLUMN-WIDTH-LIST A list that records the width (in characters) + of each column. +MIN-WIDTH-LIST A list that records the minimum width (in + characters) of each column. +CELL-MATRIX A list of list of strings. Each string is a cell. + Cells don’t contain newlines. + +Each cell is a string, the cell doesn’t contain newlines. Column +width can be smaller than the string length of a cell, in which +case means the line cell is filled to that width." + column-width-list + min-width-list + matrix) + +(cl-deftype ftable-cell () '(satisfies stringp)) + +(cl-defmethod ftable--row-count ((table ftable)) + "Return the number of rows in TABLE." + (length (ftable-matrix table))) + +(cl-defmethod ftable--column-count ((table ftable)) + "Return the number of columns in TABLE." + (length (car (ftable-matrix table)))) + +;;; Parse +;; +;; Transforming between text and table structure + +(defvar ftable-box-charset-alist + '((ascii . " ++-++ +| || ++-++ ++-++") + (unicode . " +┌─┬┐ +│ ││ +├─┼┤ +└─┴┘")) + "An alist of (NAME . CHARSET). +A charset tells ftable how to parse the table. I.e., what are the +box drawing characters to use. Don’t forget the first newline. +NAME is the mnemonic for that charset.") + +(defun ftable-box-char (code charset) + "Return a specific box drawing character in CHARSET. + +Return a string. CHARSET should be like `ftable-box-char-set'. +Mapping between CODE and position: + + ┌┬┐ 123 + ├┼┤ <-> 456 + └┴┘ 789 + + ┌─┐ 1 H 3 H: horizontal + │ │ <-> V V V: vertical + └─┘ 7 H 9 + +Examples: + + (ftable-box-char 'h charset) => \"─\" + (ftable-box-char 2 charset) => \"┬\"" + (let ((index (pcase code + ('h 10) + ('v 11) + ('n 12) + ('s 13) + (_ code)))) + + (char-to-string + (aref charset ; 1 2 3 4 5 6 7 8 9 H V N S + (nth index '(nil 1 3 4 11 13 14 16 18 19 2 6 0 7)))))) + +;; Check `ftable-box-char' with the following form, you should see: +;; ┌─┬┐ +;; │ ││ +;; ├─┼┤ +;; └─┴┘ +;; (dolist (code '( +;; 1 h 2 3 n +;; v s v v n +;; 4 h 5 6 n +;; 7 h 8 9 n)) +;; (insert (ftable-box-char code (cdadr ftable-box-charset-alist)))) + +(define-error 'ftable-parse-error "Error parsing table") + +(cl-defmethod ftable--parse-to ((table-type (eql ftable)) text + &optional box-charset) + "Parse TEXT into a table of TABLE-TYPE. +For BOX-CHARSET, see documentation of `ftable-box-charset-alist'. +It defaults to the first charset." + (ignore table-type) + ;; TODO Handle parse error. + (let ((charset (or box-charset (cdar ftable-box-charset-alist))) + line-list + matrix + buffer) + ;; TEXT: + ;; ┌──┬─┐ + ;; │ab│c│ + ;; ├──┼─┤ + ;; │de│f│ + ;; │gh│i│ + ;; └──┴─┘ + ;; 1. Split into lines. + (setq line-list (split-string text "\n")) + ;; LINE-LIST: + ;; ("┌──┬─┐" "│ab│c│" "├──┼─┤" "│de│f│" "│gh│i│" "└──┴─┘") + ;; + ;; 2. Group each line into columns. + (dolist (line line-list) + (setq line (string-trim line)) + (if (or (string-prefix-p (ftable-box-char 1 charset) line) + (string-prefix-p (ftable-box-char 4 charset) line) + (string-prefix-p (ftable-box-char 7 charset) line)) + ;; Delimiter line, i.e. ┌──┬─┐, ├──┼─┤, etc. + (progn (when buffer + (push (reverse buffer) matrix)) + (setq buffer nil)) + (push (ftable--tokenize-line line charset) buffer))) + (setq matrix (reverse matrix)) + ;; Sanity check. + (when (not (ftable--check-dimension matrix)) + (signal 'ftable-parse-error '("Dimension mismatch"))) + ;; MATRIX: + ;; ((("ab" "c")) (("de" "f") ("gh" "i"))) + ;; + ;; 3. Merge lines that belongs to the same row. + (setq matrix (mapcar #'ftable--merge-lines matrix)) + ;; MATRIX: + ;; (("ab" "c") ("de gh" "f i")) + (make-ftable + :column-width-list + (mapcar (lambda (column) + (apply #'max (mapcar #'string-width column))) + (cl-loop for n from 0 to (1- (length (car matrix))) + collect (ftable--nth-column n matrix))) + :min-width-list + (ftable--min-column-width matrix) + :matrix matrix))) + +(defun ftable--check-dimension (matrix) + "Check that the dimension of MATRIX is correct. +Correct dimension means each row has the same number of columns. +Return t if the dimension is correct, nil if not." + (let* ((matrix (apply #'append matrix)) + (first-row-column-count (length (car matrix)))) + (cl-loop for row in (cdr matrix) + if (not (eq first-row-column-count (length row))) + return nil + finally return t))) + +(defun ftable--tokenize-line (text-line box-charset) + "Tokenize TEXT-LINE into a list of tokens. + +Each token belongs to a cell. I.e., + + (ftable--tokenize-line \"│a│b│c│\") => (\"a\" \"b\" \"c\") + +BOX-CHARSET is the same as in `ftable--parse-to'. + +Assumes each line begines with box drawing characters, i.e., no +white space characters." + (mapcar #'string-trim + (split-string (string-trim + text-line + (ftable-box-char 'v box-charset) + (ftable-box-char 'v box-charset)) + (ftable-box-char 'v box-charset)))) + +(defun ftable--merge-lines (line-list) + "Merge lines in LINE-LIST together. + + (ftable--merge-lines '((\"1\" \"2\" \"3\") (\"a\" \"b\" \"c\"))) + => (\"1 a\" \"2 b\" \"3 c\") + +Assumes each line in LINE-LIST has the same length." + (let (row) + ;; Initialize ROW. + (dotimes (_ (length (nth 0 line-list))) + (push "" row)) + ;; Append cell contents. + (dolist (line line-list) + (dotimes (col-idx (length line)) + (setf (nth col-idx row) + (concat (nth col-idx row) " " + (nth col-idx line))))) + (mapcar #'string-trim row))) + +(defun ftable--nth-column (n matrix) + "Return the Nth column of MATRIX." + (mapcar (lambda (row) (nth n row)) matrix)) + +(defun ftable--min-column-width (matrix) + "Return the minimum width of each column in MATRIX." + (with-temp-buffer + (mapcar (lambda (column) + (cl-loop for cell in column + maximize + (progn + (erase-buffer) + (insert cell) + (let ((fill-column 1)) + (fill-region-as-paragraph + (point-min) (point-max))) + (ftable--max-line-width)))) + (cl-loop for col from 0 to (1- (length (car matrix))) + collect (ftable--nth-column col matrix))))) + +;;; Fill + +(cl-defmethod ftable--fill ((table ftable) table-max-width) + "Return a new TABLE that fits in TABLE-MAX-WIDTH. +Try to fit in TABLE-MAX-WIDTH, if not possible, return the +mininum width table." + (let ((desired-width table-max-width) + table-height) + (when (< table-max-width (ftable--min-width table)) + (setq desired-width (ftable--min-width table))) + ;; While we haven’t satisfied the requirement and there is still + ;; room for improvement: + (while (< desired-width (ftable--width table)) + (setq table-height (ftable--height table)) + (let ((candidate-list + ;; A list of (delta of height . new table). + (cl-loop + for col = 0 then (1+ col) + for col-width in (ftable-column-width-list table) + for min-width in (ftable-min-width-list table) + if (> col-width min-width) + collect + (let ((new-table + (ftable--shrink-column table col 1))) + (cons (- (ftable--height new-table) + table-height) + new-table))))) + (if (= 0 (length candidate-list)) + (debug)) + (setq table + (if (< (length candidate-list) 2) + (cdar candidate-list) + (cdr + (cl-reduce + ;; Find argmin(delta of height). + (lambda (a b) + (if (< (car a) (car b)) a b)) + candidate-list)))))) + table)) + +(cl-defmethod ftable--width ((table ftable)) + "Return the width of TABLE in characters. +This width includes all the box drawing characters." + (let ((lst (ftable-column-width-list table))) + (+ (apply #'+ lst) + ;; Plus the horizontal bars. + (1+ (length lst)) + ;; Plus one space padding for each column. + (1+ (length lst))))) + +(cl-defmethod ftable--min-width ((table ftable)) + "Return the smallest possible width of TABLE." + (let ((lst (ftable-min-width-list table))) + (+ (apply #'+ lst) + ;; Plus the horizontal bars. + (1+ (length lst)) + ;; Plus one space padding for each column. + (1+ (length lst))))) + +(cl-defmethod ftable--height ((table ftable)) + "Return the height of TABLE in chracters. +This height includes all the box drawing characters." + (let ((width-list (ftable-column-width-list table)) + (matrix (ftable-matrix table))) + (+ (cl-loop for row in matrix + sum (ftable--row-height row width-list)) + (1+ (length (ftable-matrix table)))))) + +(defun ftable--row-height (row column-width-list) + "Return the height of ROW. +Each cell in ROW is first filled according to COLUMN-WIDTH-LIST, +then the height is calculated." + (with-temp-buffer + (cl-loop + for col from 0 to (1- (length row)) + ;; For each cell, fill the cell and count lines. + maximize (let ((cell (nth col row)) + (width (nth col column-width-list))) + (erase-buffer) + (insert cell) + (let ((fill-column width)) + (fill-region-as-paragraph (point-min) (point-max)) + (count-lines (point-min) (point-max))))))) + +(cl-defmethod ftable--shrink-column ((table ftable) n step) + "Shrink column N of TABLE by STEP character. +Return a new table with shrinked column." + (let ((width-list (ftable-column-width-list table)) + (min-list (ftable-min-width-list table)) + (matrix (ftable-matrix table))) + (setf (nth n width-list) + (- (nth n width-list) step)) + (make-ftable + :column-width-list width-list + :min-width-list min-list + :matrix matrix))) + +(defun ftable--max-line-width () + "Return the maximum line width in buffer." + (apply #'max + (mapcar #'string-width + (split-string (buffer-string) "\n")))) + +;;; Unparse + +(cl-defmethod ftable--unparse ((table ftable) &optional box-charset) + "Export TABLE to text form. +BOX-CHARSET is the same as in `ftable--parse-to'." + (let ((charset (or box-charset (cdar ftable-box-charset-alist))) + (matrix (ftable-matrix table)) + (column-width-list (ftable-column-width-list table))) + ;; MATRIX: + ;; (("abc def" "123") + ;; ("ghi" "m")) + ;; + ;; WIDTH-LIST: + ;; (3 3) + ;; + ;; 1. Split each row into lines. + (setq matrix (mapcar (lambda (row) + (ftable--split-row row column-width-list)) + matrix)) + ;; MATRIX: + ;; ((("abc" "123") + ;; ("def" "")) + ;; (("ghi" "m"))) + ;; + ;; We add a one-space padding to each column (only) when drawing + ;; the table. + (setq column-width-list (mapcar #'1+ column-width-list)) + (with-temp-buffer + (cl-loop + ;; Draw the top border. + initially do + (ftable--insert-grid-line column-width-list '(1 2 3) charset) + for row in matrix + ;; Draw lines of each row. + do (cl-loop + for line in row do + (cl-loop initially do + (insert (ftable-box-char 'v charset)) + for column in line + for width in column-width-list + do (insert (ftable--pad-to column width)) + do (insert (ftable-box-char 'v charset)) + finally do (insert "\n"))) + ;; Draw the separator line. + (ftable--insert-grid-line column-width-list '(4 5 6) charset) + ;; Draw the bottom border. + finally do + (progn + (forward-line -1) + (delete-region (line-beginning-position) (line-end-position)) + (ftable--insert-grid-line + column-width-list '(7 8 9) charset))) + + (string-trim (buffer-string))))) + +;; (defun ftable--transpose (matrix) +;; "Transpose MATRIX." +;; (cl-loop for col-idx from 0 to (1- (length (car matrix))) +;; collect +;; (cl-loop for row in matrix +;; collect (nth col-idx row)))) + +(defun ftable--insert-grid-line (column-width-list codeset charset) + "Insert a grid line that separates cells vertically. +For example, ├──┼─┤. COLUMN-WIDTH-LIST is the one in `ftable' +struct. CODESET is a list of codes that corresponds to the left, +middle and right box drawing character codes to pass to +`ftable-box-char'. It can be (1 2 3), (4 5 6), or (7 8 9). +CHARSET is the same as BOX-CHARSET in `ftable--parse'." + (let ((left (ftable-box-char (nth 0 codeset) charset)) + (middle (ftable-box-char (nth 1 codeset) charset)) + (right (ftable-box-char (nth 2 codeset) charset))) + (cl-loop + initially do (insert left) + for width in column-width-list + do (dotimes (_ width) (insert (ftable-box-char 'h charset))) + do (insert middle) + finally do (progn (backward-delete-char 1) + (insert right "\n"))))) + +(defun ftable--split-row (row column-width-list) + "Split ROW into several lines according to COLUMN-WIDTH-LIST. +This is the opposite of `ftable--merge-lines'. + +Return value has the form of: + + ((abc 123 ...) (def 456 ...) ...) + +which corresponds to + + |abc|123|...| + |def|456|...| + ..." + (let (line-count line-list line) + (with-temp-buffer + (setq row (cl-loop + for cell in row + for width in column-width-list + collect (progn + (erase-buffer) + (insert cell) + (let ((fill-column width)) + (fill-region-as-paragraph + (point-min) (point-max))) + (split-string (string-trim (buffer-string)) + "\n")))) + (setq line-count (apply #'max (mapcar #'length row))) + (dotimes (idx line-count) + (setq line nil) + (dolist (cell row) + (push (or (nth idx cell) "") line)) + (push (reverse line) line-list)) + (reverse line-list)))) + +(defun ftable--pad-to (text width) + "Append padding to TEXT until it is WIDTH characters long. +Return a new string." + (if (< (string-width text) width) + (concat text (make-vector (- width (string-width text)) ?\s)) + text)) + +;;; Convenience + +;;;###autoload +(defun ftable-fill () + "Fill the table (or paragraph) at point." + (interactive) + (pcase-let ((`(,text ,beg ,end ,cell-p ,tablep , charset) + (ftable--table-info))) + (if tablep + (ftable--replace-text + beg end text + (string-trim + (ftable--unparse + (ftable--fill (ftable--parse-to + 'ftable text charset) + ftable-fill-column) + charset)) + (when cell-p + #'table-recognize-region)) + (fill-paragraph)))) + +;;;###autoload +(defun ftable-edit-cell () + "Edit the cell at point." + (interactive) + (pcase-let* ((pt (point)) + (p-column (- (point) (line-beginning-position))) + (`(,text ,beg ,end ,cell-p,tablep ,charset) + (ftable--table-info)) + (x -1) + ;; If these two characters are the same, we will count + ;; one extra. + (y (if (equal (ftable-box-char 3 charset) + (ftable-box-char 6 charset)) + -1 0))) + (if (not tablep) + (user-error "There is no table at point") + (save-excursion + (goto-char beg) + ;; Parse out the coordinate of the cell at point. + (while (search-forward + (format "%s\n" (ftable-box-char 6 charset)) + pt t) + (cl-incf y)) + (while (search-forward + (ftable-box-char 'v charset) + (+ (line-beginning-position) p-column) t) + (cl-incf x))) + ;; Prompt user to edit. + (let* ((table (ftable--parse-to 'ftable text charset)) + (cell (nth x (nth y (ftable-matrix table)))) + (new-cell (read-string "Edit: " cell))) + (setf (nth x (nth y (ftable-matrix table))) new-cell) + ;; Apply change. + (ftable--replace-text + beg end text + (ftable--unparse + (ftable--fill table ftable-fill-column) + charset) + (when cell-p + #'table-recognize-region)))))) + +;;;###autoload +(defun ftable-reformat (style) + "Change box drawing STYLE for table at point. +STYLE can be ’ascii or ’unicode." + (interactive (list (intern + (downcase + (completing-read "Style: " + '("ASCII" "Unicode")))))) + (pcase-let ((`(,text ,beg ,end ,cell-p ,tablep ,charset) + (ftable--table-info))) + (if (not tablep) + (user-error "There is no table at point") + (ftable--replace-text + beg end text + (ftable--unparse + ;; We still need to fill the table, otherwise it will be + ;; the widest table layout. + (ftable--fill + (ftable--parse-to 'ftable text charset) + ftable-fill-column) + (alist-get style ftable-box-charset-alist)) + (when cell-p + #'table-recognize-region))))) + +(defun ftable--at-table-p () + "Return non-nil if point is in a table." + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (member (char-to-string (char-after)) + (append + (cl-loop for elt in ftable-box-charset-alist + for charset = (cdr elt) + collect (ftable-box-char 1 charset) + collect (ftable-box-char 4 charset) + collect (ftable-box-char 7 charset) + collect (ftable-box-char 'v charset)))))) + +(defun ftable--beginning-of-table () + "Go backward to the beginning of the table at point. +Assumes point is on a table." + ;; This implementation allows non-table lines before a table, e.g., + ;; #+latex: xxx + ;; |------+----| + (when (ftable--at-table-p) + (beginning-of-line)) + (while (and (< (point-min) (point)) + (ftable--at-table-p)) + (forward-line -1)) + (unless (ftable--at-table-p) + (forward-line 1))) + +(defun ftable--end-of-table () + "Go forward to the end of the table at point. +Assumes point is on a table." + (let ((start (point))) + (when (ftable--at-table-p) + (beginning-of-line)) + (while (and (< (point) (point-max)) + (ftable--at-table-p)) + (forward-line 1)) + (unless (<= (point) start) + (skip-chars-backward "\n")) + (when (< (point) start) + (error "End of table goes backwards")))) + +(defun ftable--table-info () + "Return (TEXT BEG END TABLE-CELL-P TABLEP CHARSET). +TEXT is the table’s text. BEG and END are the beginning and end +position of the table, not including any newlines. TABLE-CELL-P +is t if the table is managed by table.el. TABLEP is t if point is +on a table, nil if not. CHARSET is the box drawing charset used +by the table (if there is a table). \(See +`ftable-box-charset-alist'.)" + (let* ((beg (save-excursion + (ftable--beginning-of-table) + (point))) + (end (save-excursion + (ftable--end-of-table) + (point))) + (text (buffer-substring-no-properties beg end)) + (table-cell-p (text-property-any beg end 'table-cell t))) + (append (list text beg end table-cell-p) + (cl-loop for charset + in (mapcar #'cdr ftable-box-charset-alist) + if (equal (substring text 0 1) + (ftable-box-char 1 charset)) + return (list t charset) + finally return (list nil nil))))) + +(defun ftable--replace-text (beg end text new-text &optional fn) + "Replace TEXT between BEG and END with NEW-TEXT. +If FN non-nil, run it with the new BEG and END after replacing +the text. I.e., (FN BEG END)." + (unless (equal text new-text) + (let ((p (point))) + (delete-region beg end) + (insert new-text) + (setq end (point)) + ;; Go back to roughly where we were. + (goto-char p) + (when fn (funcall fn beg end))))) + +;;; Test + +(with-eval-after-load 'ert + (ert-deftest ftable--misc-test () + (let ((text (string-trim " +┌──┬─┐ +│ab│c│ +├──┼─┤ +│de│f│ +│gh│i│ +└──┴─┘"))) + (should (equal + (ftable--parse-to 'ftable text + (cdadr ftable-box-charset-alist)) + (make-ftable + :column-width-list '(5 3) + :min-width-list '(2 1) + :matrix '(("ab" "c") ("de gh" "f i")))))) + ;; ftable--tokenize-line + (should (equal (mapcar (lambda (x) + (ftable--tokenize-line + x (cdadr ftable-box-charset-alist))) + '( "│ab│c│" "│de│f│" "│gh│i│")) + '(("ab" "c") ("de" "f") ("gh" "i") ))) + (should (equal (ftable--tokenize-line + "|fgh| | z|" (cdar ftable-box-charset-alist)) + '("fgh" "" "z"))) + ;; ftable--merge-lines + (should (equal (mapcar #'ftable--merge-lines + '((("ab" "c")) (("de" "f") ("gh" "i")))) + '(("ab" "c") ("de gh" "f i")))) + ;; ftable--nth-column + (should (equal (ftable--nth-column 1 '((1 2 3) (4 5 6) (7 8 9))) + '(2 5 8))) + ;; ftable--row-height + (should (equal (ftable--row-height '("ab c" "def" "ghi") '(2 3 3)) + 2)) + ;; ftable--split-row + (should (equal (ftable--split-row '("abc de" "12" "xy z") + '(3 2 2)) + '(("abc" "12" "xy") ("de" "" "z")))) + ;; ftable--pad-to + (should (equal (ftable--pad-to "123" 5) + "123 ")))) + + +(provide 'ftable) + +;;; ftable.el ends here diff --git a/homebase/public/.emacs.d/locext/ftable/ftable.gif b/homebase/public/.emacs.d/locext/ftable/ftable.gif new file mode 100644 index 00000000..2cf8552c Binary files /dev/null and b/homebase/public/.emacs.d/locext/ftable/ftable.gif differ diff --git a/homebase/public/.emacs.d/locext/good-scroll.el/.dir-locals.el b/homebase/public/.emacs.d/locext/good-scroll.el/.dir-locals.el new file mode 100644 index 00000000..002211c9 --- /dev/null +++ b/homebase/public/.emacs.d/locext/good-scroll.el/.dir-locals.el @@ -0,0 +1 @@ +((emacs-lisp-mode . ((indent-tabs-mode . nil)))) diff --git a/homebase/public/.emacs.d/locext/good-scroll.el/.gitignore b/homebase/public/.emacs.d/locext/good-scroll.el/.gitignore new file mode 100644 index 00000000..c531d986 --- /dev/null +++ b/homebase/public/.emacs.d/locext/good-scroll.el/.gitignore @@ -0,0 +1 @@ +*.elc diff --git a/homebase/public/.emacs.d/locext/good-scroll.el/LICENSE b/homebase/public/.emacs.d/locext/good-scroll.el/LICENSE new file mode 100644 index 00000000..0b8fede9 --- /dev/null +++ b/homebase/public/.emacs.d/locext/good-scroll.el/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2021 Benjamin Levy + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/homebase/public/.emacs.d/locext/good-scroll.el/README.md b/homebase/public/.emacs.d/locext/good-scroll.el/README.md new file mode 100644 index 00000000..388de0c0 --- /dev/null +++ b/homebase/public/.emacs.d/locext/good-scroll.el/README.md @@ -0,0 +1,76 @@ +[![MELPA](https://melpa.org/packages/good-scroll-badge.svg)](https://melpa.org/#/good-scroll) +[![Check](https://github.com/io12/good-scroll.el/actions/workflows/check.yml/badge.svg)](https://github.com/io12/good-scroll.el/actions/workflows/check.yml) + +# `good-scroll.el` + +Attempt at good pixel-based smooth scrolling in Emacs + +## About + +This package implements smooth scrolling by pixel lines. +It attempts to improve upon `pixel-scroll-mode` by adding variable speed. + +![Demo](./demo.gif) + +## Setup + +Install and load the package. +Then, enable `good-scroll-mode`. +For example, you can add the following snippet to your config. + +```lisp +(good-scroll-mode 1) +``` + +### Key bindings + +If you want to bind the Page Up and Page Down keys, +you can also add the following: + +```lisp +(global-set-key [next] #'good-scroll-up-full-screen) +(global-set-key [prior] #'good-scroll-down-full-screen) +``` + +## FAQ + +### How does this work? + +Instead of scroll events directly scrolling the screen, +they update a destination variable. +A timer that runs every `good-scroll-render-rate` seconds +calculates the expected position and actually scrolls the window to it. +To make the window scrolled partially through a line, +`good-scroll` updates the window's +[_vscroll_ (vertical scroll)](https://www.gnu.org/software/emacs/manual/html_node/elisp/Vertical-Scrolling.html) +position. + +### Why is performance sometimes bad? + +Scrolling sometimes pauses or stutters. +It's unclear _exactly_ why, +but one factor is that Emacs lacks animation support. +Emacs has timers for updating the screen contents, +which is enough for playing simple animated GIF files, +but not enough for video playback or frame-perfect smooth scrolling. + +### How does this compare to other scrolling packages? + +Other modifications, like +[`smooth-scrolling`](https://github.com/aspiers/smooth-scrolling), +[`smooth-scroll`](https://github.com/k-talo/smooth-scroll.el), +[`sublimity-scroll`](https://github.com/zk-phi/sublimity), +and [`inertial-scroll`](https://github.com/kiwanami/emacs-inertial-scroll) +also aim to improve scrolling in Emacs, +but none of them involve scrolling by pixel lines, only by text lines. +The built-in +[`pixel-scroll`](https://git.savannah.gnu.org/cgit/emacs.git/tree/lisp/pixel-scroll.el) +_does_ implement pixel line scrolling, +but, unlike `good-scroll`, does not support dynamic scrolling velocity. + +### Why is this file written in Markdown and not Org? + +Apparently, GitHub does not yet support rendering +Org links with formatting inside of them. + +https://github.com/novoid/github-orgmode-tests/issues/3 diff --git a/homebase/public/.emacs.d/locext/good-scroll.el/demo.gif b/homebase/public/.emacs.d/locext/good-scroll.el/demo.gif new file mode 100644 index 00000000..db2425ed Binary files /dev/null and b/homebase/public/.emacs.d/locext/good-scroll.el/demo.gif differ diff --git a/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll-bezier.el b/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll-bezier.el new file mode 100644 index 00000000..5563dfb6 --- /dev/null +++ b/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll-bezier.el @@ -0,0 +1,333 @@ +;;; good-scroll-bezier.el --- Bézier scrolling algorithm -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Benjamin Levy - MIT/X11 License +;; Author: Benjamin Levy +;; Homepage: https://github.com/io12/good-scroll.el + +;; Permission is hereby granted, free of charge, to any person obtaining a copy +;; of this software and associated documentation files (the "Software"), to deal +;; in the Software without restriction, including without limitation the rights +;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;; copies of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in all +;; copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +;;; Commentary: + +;; This implements a scrolling algorithm for `good-scroll' +;; based on Bézier curves. +;; This is newer and feels smoother than `good-scroll-linear', +;; but is more complicated. +;; Set `good-scroll-algorithm' to `good-scroll-bezier-position' to enable. + +;;; Code: + +(require 'cl-lib) + + + +;;;; General Bézier curve calculations + +(defconst good-scroll-bezier--epsilon 0.0001 + "Epsilon for checking if floats are approximately equal. +The function `good-scroll-bezier--approx-eq-p' uses this. +Decreasing this `good-scroll-bezier--t-given-x' more accurate, but slower.") + +(defun good-scroll-bezier--calc (tt p1 p2) + "Compute the cubic Bézier polynomial at TT with control points [0, P1, P2, 1]. +The calculation is one-dimensional, +meaning TT, P1, and P2 are numbers instead of vectors. +Two-dimensional calculations can be done by evaluating this function twice, +once for each of the X and Y values of the control points P1 and P2. +More information can be found at the URL +`https://en.wikipedia.org/wiki/B%C3%A9zier_curve#Cubic_B%C3%A9zier_curves'." + (+ (* 3 (expt (- 1 tt) 2) tt p1) + (* 3 (- 1 tt) (expt tt 2) p2) + (expt tt 3))) + +(defun good-scroll-bezier--deriv (tt p1 p2) + "Compute the derivative of `good-scroll-bezier--calc' with respect to TT. +Compute the derivative of the cubic Bézier polynomial +defined by the control points [0, P1, P2, 1]." + (+ (* 3 (expt (- 1 tt) 2) p1) + (* 6 (- 1 tt) tt (- p2 p1)) + (* 3 (expt tt 2) (- 1 p2)))) + +(defun good-scroll-bezier--approx-eq-p (a b &optional epsilon) + "Return whether the floating point values A and B are approximately equal. +The floats are considered approximately equal +if they differ by less than EPSILON, +or `good-scroll-bezier--epsilon' if EPSILON is nil." + (< (abs (- a b)) + (or epsilon good-scroll-bezier--epsilon))) + +(defun good-scroll-bezier--t-given-x (x x1 x2 &optional t-min t-max) + "Estimate the t value of a cubic Bézier curve. +Given X (the output of the Bézier formula), +return the corresponding input value TT between T-MIN and T-MAX. +The Bézier curve is defined by the control points [0, X1, X2, 1]. +The value of X must be in the interval [0,1]." + ;; Use recursive binary search. + ;; This works because the curve is always monotonically increasing. + ;; Another approach is using Newton's method, + ;; but that can be slow or get stuck when the slope is close to zero. + (cl-assert (<= 0.0 x 1.0)) + (let* ( + (t-min (or t-min 0.0)) + (t-max (or t-max 1.0)) + (t-mid (/ (+ t-min t-max) 2)) + (x- (good-scroll-bezier--calc t-mid x1 x2))) + (cond + ;; Equal + ((good-scroll-bezier--approx-eq-p x- x) + ;; Return the approximation + t-mid) + ;; Less than + ((< x- x) + ;; Try upper half + (good-scroll-bezier--t-given-x x x1 x2 t-mid t-max)) + ;; Greater than + (t + ;; Try lower half + (good-scroll-bezier--t-given-x x x1 x2 t-min t-mid))))) + + + +;;;; Integration with `good-scroll' + +(defgroup good-scroll-bezier nil + "Good-scroll Bézier scrolling algorithm" + :group 'good-scroll) + +;;;;; Bézier curve control points + +(defvar good-scroll-bezier--x1 nil + "X coordinate of first control point.") +(defvar good-scroll-bezier--y1 nil + "Y coordinate of first control point.") +(defvar good-scroll-bezier--x2 0.6 + "X coordinate of second control point.") +(defvar good-scroll-bezier--y2 1.0 + "Y coordinate of second control point.") + +;;;;; Information about previous scroll event + +(defvar good-scroll-bezier--prev-time 0.0 + "Time of the last received scroll event. +This is used for checking for new scroll events.") + +(defvar good-scroll-bezier--prev-direction 0 + "Direction of the last received scroll event. +This is used for checking if the direction changed in a scroll event.") + +;;;;; Bézier curve visualization options + +(defcustom good-scroll-bezier-image-display nil + "When non-nil, display an animation of the current Bézier curve. +Because of garbage collector pauses, this is very slow." + :group 'good-scroll-bezier + :type 'boolean) + +(defcustom good-scroll-bezier-image-size 50 + "Size of Bézier curve image to draw. +When the variable `good-scroll-bezier-image-display' is non-nil, +this is the side length of the image in pixels. +Larger values may have significantly worse performance." + :group 'good-scroll-bezier + :type 'integer) + +(defun good-scroll-bezier--set-points (velocity) + "Update the control points. +Modify the control points such that `(good-scroll-bezier--velocity-at 0.0)' +will return approximately VELOCITY." + (let* ( + ;; Total distance the scroll will have traveled when it finishes + (total-distance (+ good-scroll-traveled good-scroll-destination)) + ;; Reconstruct dy/dx from velocity by reversing operations + ;; at the end of `good-scroll-bezier--velocity-at'. + (dy/dx (* velocity (/ good-scroll-duration total-distance))) + ;; This is similar to `(abs dy/dx)', + ;; but if `dy/dx' is zero then `normalization' is 1. + (normalization (sqrt (+ 1.0 (expt dy/dx 2)))) + (normalization (/ 0.25 normalization)) + ;; The goal is to choose values `x' and `y' + ;; such that `(/ y x)' equals `dy/dx'. + ;; TODO: Talk about normalization + (x normalization) + (y (* dy/dx normalization))) + ;; The first control point should determine the dy/dx when t is zero, + ;; and therefore preserve the velocity. + (setq good-scroll-bezier--x1 x + good-scroll-bezier--y1 y))) + +(defun good-scroll-bezier--velocity-at (fraction-done) + "Return the current velocity of the scrolling in pixel-lines per second. +The argument FRACTION-DONE is a number between 0.0 and 1.0, +indicating completion progress." + (let* ( + (tt (good-scroll-bezier--t-given-x fraction-done + good-scroll-bezier--x1 + good-scroll-bezier--x2)) + (dx/dt (good-scroll-bezier--deriv tt + good-scroll-bezier--x1 + good-scroll-bezier--x2)) + (dy/dt (good-scroll-bezier--deriv tt + good-scroll-bezier--y1 + good-scroll-bezier--y2)) + ;; Slope of line tangent to the Bézier curve + (dy/dx (/ dy/dt dx/dt)) ; TODO make sure dx/dt != 0 + ;; Total distance the scroll will have traveled when it finishes + (total-distance (+ good-scroll-traveled good-scroll-destination))) + ;; The x-axis of the Bézier curve represents time + ;; and the y-axis represents position. + ;; However, the domain and range are both [0, 1], + ;; so we need to scale the curve by the total distance and duration. + ;; The slope dy/dx represents what the speed would be + ;; if the distance and duration were both 1. + ;; So we need to scale the slope with the distance and duration. + (* dy/dx (/ total-distance good-scroll-duration)))) + +(defun good-scroll-bezier--position (fraction-done) + "Return the current position of the scroll in pixel-lines. +The argument FRACTION-DONE is a number between 0.0 and 1.0, +indicating time-based completion progress." + (let* ( + (tt (good-scroll-bezier--t-given-x fraction-done + good-scroll-bezier--x1 + good-scroll-bezier--x2)) + ;; Pixel-based scroll progress + (progress (good-scroll-bezier--calc tt + good-scroll-bezier--y1 + good-scroll-bezier--y2))) + (round (- (* progress (+ good-scroll-traveled + good-scroll-destination)) + good-scroll-traveled)))) + +(defun good-scroll-bezier--update (fraction-done) + "Update the Bézier curve's control points. +Modify the control points such that velocity is preserved. +Assume the scroll's progress is FRACTION-DONE." + ;; Try to get the velocity, + ;; or use zero if the first control point is uninitialized. + (let ((velocity (if good-scroll-bezier--x1 + (good-scroll-bezier--velocity-at fraction-done) + 0.0))) + ;; Actually update the control points + (good-scroll-bezier--set-points velocity))) + +(defun good-scroll-bezier () + "Bézier scrolling algorithm. +Return the next position in pixel lines. +Update the internal Bézier curve on new scroll events." + (let* ((time (float-time)) + (elapsed-time (- time good-scroll-start-time)) + (prev-elapsed-time (- time good-scroll-bezier--prev-time)) + (fraction-done (min 1.0 (/ elapsed-time good-scroll-duration))) + (prev-fraction-done (min 1.0 (/ prev-elapsed-time good-scroll-duration))) + (direction-changed-p (<= (* good-scroll-direction + good-scroll-bezier--prev-direction) + 0))) + + ;; Update Bézier curve visualization + (when good-scroll-bezier-image-display + (let ((window (selected-window))) + (good-scroll-bezier-image-display good-scroll-bezier-image-size + good-scroll-bezier-image-size + fraction-done) + (select-window window))) + + ;; New scroll event received? + (when (/= good-scroll-bezier--prev-time good-scroll-start-time) + ;; Got a new scroll event, so update the Bézier curve. + (if direction-changed-p + ;; Zero velocity if direction changed + (good-scroll-bezier--set-points 0.0) + ;; Maintain velocity if direction stayed the same + (good-scroll-bezier--update prev-fraction-done))) + + ;; Mark this scroll event as received + (setq good-scroll-bezier--prev-time good-scroll-start-time) + (setq good-scroll-bezier--prev-direction good-scroll-direction) + + (good-scroll-bezier--position fraction-done))) + + + +;;;;; Visualize image of Bézier curve in a separate window + +(defun good-scroll-bezier--bitmap (width height fraction-done) + "Return a bitmap of the current Bézier curve. +Return a vector of vectors of integers representing the bitmap. +Each integer is a pixel, and is zero for black and one for white. +The dimensions of the bitmap are given by WIDTH and HEIGHT. +Draw a vertical line at FRACTION-DONE." + (let ((bitmap (make-vector height nil))) + ;; Initialize rows + (dotimes (y height) + (aset bitmap y (make-vector width 0))) + ;; Plot progress line + (let ((x (truncate (* fraction-done 0.99 width)))) + (dotimes (y height) + (aset (aref bitmap y) x 1))) + ;; Plot control points + (let ((x1 (truncate (* good-scroll-bezier--x1 0.99 width))) + (x2 (truncate (* good-scroll-bezier--x2 0.99 width))) + (y1 (truncate (* good-scroll-bezier--y1 0.99 height))) + (y2 (truncate (* good-scroll-bezier--y2 0.99 height)))) + (aset (aref bitmap y1) x1 1) + (aset (aref bitmap y2) x2 1)) + ;; Set a bit in each column (as part of the curve) + (dotimes (x width) + (let* ((tt (good-scroll-bezier--t-given-x (/ (float x) width) + good-scroll-bezier--x1 + good-scroll-bezier--x2)) + (y-frac (good-scroll-bezier--calc tt + good-scroll-bezier--y1 + good-scroll-bezier--y2)) + (y (truncate (* y-frac height)))) + (aset (aref bitmap y) x 1))) + bitmap)) + +(defun good-scroll-bezier--image (width height fraction-done) + "Return a string with a PBM image of the current Bézier curve. +The dimensions of the image are given by WIDTH and HEIGHT. +Draw a vertical line at FRACTION-DONE." + (format "P1\n# good-scroll test bitmap\n%d %d\n%s" + width + height + (mapconcat (lambda (row) (mapconcat #'number-to-string row " ")) + (reverse (good-scroll-bezier--bitmap width + height + fraction-done)) + "\n"))) + +(defun good-scroll-bezier-image-display (width height fraction-done) + "Display an image of the current Bézier curve. +The dimensions of the image are given by WIDTH and HEIGHT. +Draw a vertical line at FRACTION-DONE." + (cl-assert (<= 0.0 fraction-done 1.0)) + (let ((buffer (get-buffer-create " *good-scroll-bezier-image-display*"))) + (with-current-buffer buffer + (erase-buffer) + (insert-image + (create-image (good-scroll-bezier--image width height fraction-done) + nil + t + :scale 1))) + (pop-to-buffer buffer))) + + + +(provide 'good-scroll-bezier) + +;;; good-scroll-bezier.el ends here diff --git a/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll-linear.el b/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll-linear.el new file mode 100644 index 00000000..458a0d0f --- /dev/null +++ b/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll-linear.el @@ -0,0 +1,46 @@ +;;; good-scroll-linear.el --- Linear scrolling algorithm -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Benjamin Levy - MIT/X11 License +;; Author: Benjamin Levy +;; Homepage: https://github.com/io12/good-scroll.el + +;; Permission is hereby granted, free of charge, to any person obtaining a copy +;; of this software and associated documentation files (the "Software"), to deal +;; in the Software without restriction, including without limitation the rights +;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;; copies of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in all +;; copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +;;; Commentary: + +;; This library implements an algorithm for `good-scroll' +;; that linearly interpolates the position in pixel lines. +;; It's older, simpler, and feels less smooth than `good-scroll-bezier'. +;; Set `good-scroll-algorithm' to `good-scroll-linear' to enable. + +;;; Code: + +(defun good-scroll-linear () + "Linear scrolling algorithm. +Return the next position in pixel lines. +This works by linearly interpolating position." + (let* ((elapsed (- (float-time) good-scroll-start-time)) + (fraction-done (min 1.0 (/ elapsed good-scroll-duration)))) + (round (- (* fraction-done + (+ good-scroll-traveled good-scroll-destination)) + good-scroll-traveled)))) + +(provide 'good-scroll-linear) + +;;; good-scroll-linear.el ends here diff --git a/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll-test.el b/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll-test.el new file mode 100644 index 00000000..d21da048 --- /dev/null +++ b/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll-test.el @@ -0,0 +1,112 @@ +;;; good-scroll-test.el --- Unit testing for good-scroll -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Benjamin Levy - MIT/X11 License +;; Author: Benjamin Levy +;; Homepage: https://github.com/io12/good-scroll.el +;; Package-Requires: ((emacs "27.1")) + +;; Permission is hereby granted, free of charge, to any person obtaining a copy +;; of this software and associated documentation files (the "Software"), to deal +;; in the Software without restriction, including without limitation the rights +;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;; copies of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in all +;; copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +;;; Commentary: + +;; This library contains ERT unit tests for good-scroll. +;; They can be run with `ert-run-tests-interactively'. + +;;; Code: + +(require 'good-scroll) + +(require 'ert) + + + +;;; good-scroll-linear.el + +(ert-deftest good-scroll-test-linear () + (with-temp-buffer + (cl-flet ((test-case + (traveled destination zero half one) + (set (make-local-variable 'good-scroll-duration) 1.0) + (set (make-local-variable 'good-scroll-traveled) traveled) + (set (make-local-variable 'good-scroll-destination) destination) + (set (make-local-variable 'good-scroll-start-time) (float-time)) + (should (= (good-scroll-linear) zero)) + (set (make-local-variable 'good-scroll-start-time) + (- (float-time) 0.5)) + (should (= (good-scroll-linear) half)) + (set (make-local-variable 'good-scroll-start-time) + (- (float-time) 1.0)) + (should (= (good-scroll-linear) one)))) + (test-case 0 10 0 5 10) + (test-case 0 -10 0 -5 -10) + (test-case 10 20 -10 5 20) + (test-case -10 20 10 15 20) + (test-case 10 -20 -10 -15 -20)))) + + + +;;; good-scroll-bezier.el + +(ert-deftest good-scroll-test-bezier-t-given-x () + (with-temp-buffer + (cl-flet ((test-case + (x x1 x2) + (let* ((tt (good-scroll-bezier--t-given-x x x1 x2)) + (x- (good-scroll-bezier--calc tt x1 x2))) + (should (good-scroll-bezier--approx-eq-p x x-))))) + (test-case 0.0 0.0 0.0) + (test-case 0.5 0.0 0.0) + (test-case 0.0 0.1 3.1) + (test-case 1.0 2.0 3.0) + (test-case 0.0 -0.1 3.1) + (test-case 0.0 0.1 -3.1) + (test-case 1.0 -2.0 -3.0) + (test-case 1.0 2.0 -3.0) + (test-case 0.5 2.0 3.0) + (test-case 1.0 -2.0 3.0)))) + +(ert-deftest good-scroll-test-bezier-maintain-velocity () + (with-temp-buffer + (cl-flet ((test-case + (velocity duration traveled destination epsilon half) + (set (make-local-variable 'good-scroll-duration) duration) + (set (make-local-variable 'good-scroll-traveled) traveled) + (set (make-local-variable 'good-scroll-destination) destination) + (good-scroll-bezier--set-points velocity) + (should (good-scroll-bezier--approx-eq-p + (good-scroll-bezier--velocity-at 0.0) velocity epsilon)) + (should (good-scroll-bezier--approx-eq-p + (good-scroll-bezier--velocity-at 0.5) half epsilon)) + (should (good-scroll-bezier--approx-eq-p + (good-scroll-bezier--velocity-at 1.0) 0.0 epsilon)))) + (test-case 0.0 0.1 0 1 0.01 14.2934) + (test-case 0.0 1.0 0 1 0.01 1.4293) + (test-case 0.0 10.0 0 1 0.01 0.1429) + (test-case 1.0 0.1 0 1 0.01 14.0608) + (test-case 1.0 1.0 0 1 0.01 1.1677) + (test-case 1.0 10.0 0 1 0.1 0.1406) + (test-case 1234.56 0.1 50 20 1000.0 1.0) + (test-case 1234.56 1.0 50 20 1000.0 1.0) + (test-case 1234.56 10.0 50 20 1000.0 1.0)))) + + + +(provide 'good-scroll-test) + +;;; good-scroll-test.el ends here diff --git a/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll.el b/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll.el new file mode 100644 index 00000000..b7c250c2 --- /dev/null +++ b/homebase/public/.emacs.d/locext/good-scroll.el/good-scroll.el @@ -0,0 +1,639 @@ +;;; good-scroll.el --- Good pixel line scrolling -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Benjamin Levy - MIT/X11 License +;; Author: Benjamin Levy +;; Version: 2.0.1 +;; Description: Attempt at good pixel-based smooth scrolling in Emacs +;; Homepage: https://github.com/io12/good-scroll.el +;; Package-Requires: ((emacs "27.1")) + +;; Permission is hereby granted, free of charge, to any person obtaining a copy +;; of this software and associated documentation files (the "Software"), to deal +;; in the Software without restriction, including without limitation the rights +;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;; copies of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in all +;; copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +;;; Commentary: + +;; This package implements smooth scrolling by pixel lines. It attempts to +;; improve upon `pixel-scroll-mode' by adding variable speed. + +;;; Code: + +(require 'cl-lib) + +(require 'good-scroll-bezier) +(require 'good-scroll-linear) + +(defgroup good-scroll nil + "Good pixel line scrolling" + :group 'scrolling) + +(defcustom good-scroll-render-rate 0.02 + "Number of seconds between renders. +This corresponds to the refresh rate of the scrolling animation. +For changes of this option to take effect, good-scroll mode must be restarted." + :group 'good-scroll + :type 'float) + +(defcustom good-scroll-duration 0.15 + "Duration of a scroll in seconds." + :group 'good-scroll + :type 'float) + +(defcustom good-scroll-step 80 + "Number of pixel lines to scroll during a scroll step." + :group 'good-scroll + :type 'integer) + +(defcustom good-scroll-algorithm #'good-scroll-bezier + "The scrolling animation algorithm to use. +If implementing your own algorithm, it should be a function with zero arguments. +The function should return a target position in pixel-lines relative to the top +of the window. +See the built-in algorithms for inspiration." + :group 'good-scroll + :type '(radio (function-item good-scroll-bezier) + (function-item good-scroll-linear) + function)) + +(defcustom good-scroll-persist-vscroll-line-move t + "If non-nil, avoid resetting vscroll when `line-move' is called. +Normally, when the user presses a key to move the point, +`line-move' is called, and this resets the vscroll. +If this variable is non-nil, `good-scroll' overrides this behavior. +For changing this variable to take effect, good-scroll mode must be restarted." + :group 'good-scroll + :type 'boolean) + +(defcustom good-scroll-persist-vscroll-window-scroll t + "If non-nil, restore a saved vscroll when `window-scroll-functions' is called. +There are aren't many cases where this makes a difference, +but one example is buffers with other buffers embedded inside them, +such as with the polymode package. +For changing this variable to take effect, good-scroll mode must be restarted." + :group 'good-scroll + :type 'boolean) + +(defvar good-scroll--debug nil + "Flag for enabling debug logging and slow assertions.") + +(defvar good-scroll--window nil + "The window scrolled most recently.") + +(defvar good-scroll--timer nil + "Timer for render updates.") + +(defvar good-scroll-destination nil + "Destination of the current scroll. +The unit is pixel lines relative to the top of the window. +For example, -12 means scrolling down 12 pixels.") + +(defvar good-scroll-traveled nil + "Number of pixel lines traveled so far in the current scroll.") + +(defvar good-scroll-start-time nil + "Start time of the most recent scroll.") + +(defvar good-scroll-direction 0 + "Direction of the most recent scroll. +This should be an integer. Positive means up and negative means down.") + +(defvar good-scroll--cached-point-top nil + "Cached output of `good-scroll--point-top'. +This is modified when scrolling to avoid re-running `good-scroll--point-top' +for performance reasons.") + +(defvar good-scroll--prev-point nil + "The output of `point' after the last render.") + +(defvar good-scroll--prev-window-start nil + "The output of `window-start' after the last render.") + +(defvar good-scroll--prev-vscroll nil + "The output of `(window-vscroll nil t)' after the last render.") + +(defvar good-scroll--pre-command-point nil + "The value of point before the most recent command executed. +This is used to test if a command moved the cursor.") + +;;;###autoload +(define-minor-mode good-scroll-mode + "Good pixel line scrolling" + :init-value nil + :group 'scrolling + :global t + + (if good-scroll-mode + ;; Enable major mode + (progn + (setq mwheel-scroll-up-function #'good-scroll-up + mwheel-scroll-down-function #'good-scroll-down + good-scroll--timer + (run-at-time 0 good-scroll-render-rate #'good-scroll--render)) + (when good-scroll-persist-vscroll-line-move + (advice-add 'line-move :around #'good-scroll--advice-line-move)) + (when good-scroll-persist-vscroll-window-scroll + (add-hook 'window-scroll-functions #'good-scroll--restore-vscroll)) + (add-hook 'pre-command-hook #'good-scroll--pre-command) + (add-hook 'post-command-hook #'good-scroll--post-command)) + ;; Disable major mode + (progn + (setq mwheel-scroll-up-function #'scroll-up + mwheel-scroll-down-function #'scroll-down) + (when (timerp good-scroll--timer) + (cancel-timer good-scroll--timer)) + (advice-remove 'line-move #'good-scroll--advice-line-move) + (remove-hook 'window-scroll-functions #'good-scroll--restore-vscroll) + (remove-hook 'pre-command-hook #'good-scroll--pre-command) + (remove-hook 'post-command-hook #'good-scroll--post-command)))) + +(defmacro good-scroll--log (string &rest forms) + "When `good-scroll--debug' is non-nil, log a message. +Use `message' to write a message of the form `CALLER: STRING: FORMS-STRING', +where CALLER is the function's caller +and FORMS-STRING contains the evaluated values of FORMS." + nil + (let ((forms (cons 'list (mapcar (lambda (form) `(list ',form ,form)) forms)))) + `(when good-scroll--debug + (let* ((stringify-form (lambda (form) (format "%s=%s" + (nth 0 form) + (nth 1 form)))) + (forms-string (mapconcat stringify-form ,forms ", "))) + (message "good-scroll: %s: %s" ,string forms-string))))) + +(defun good-scroll--window-and-window-start-same-p () + "Return whether the window and window start are the same. +If the selected window, and window start is the same as +it was in in the last render, return non-nil. +Otherwise, return nil." + (and good-scroll--window + good-scroll--prev-window-start + (eq good-scroll--window (selected-window)) + (= good-scroll--prev-window-start (window-start)))) + +(defun good-scroll--restore-vscroll (&rest _args) + "Restore the saved vscroll value. +If nothing but the vscroll changed since the last render, +restore the previous vscroll value. +This function is used as a hook in `window-scroll-functions'." + (when (good-scroll--window-and-window-start-same-p) + (good-scroll--log "restore vscroll" good-scroll--prev-vscroll) + (set-window-vscroll nil good-scroll--prev-vscroll t))) + +(defun good-scroll--pre-command () + "This function is called in `pre-command-hook'. +It saves the value of point in `good-scroll--pre-command-point' so that +`good-scroll--post-command' can check whether the most recent command +moved the cursor." + (setq good-scroll--pre-command-point (point))) + +(defun good-scroll--post-command () + "This function is called in `post-command-hook'. +If the most recent command made the cursor overlap the top of the window, +set the window's vscroll to zero to avoid the overlap." + (when (and good-scroll--pre-command-point + (/= good-scroll--pre-command-point (point)) + (not (zerop (window-vscroll nil t))) + (good-scroll--point-at-top-p)) + (set-window-vscroll nil 0 t))) + +(defmacro good-scroll--slow-assert (form) + "When `good-scroll--debug' is non-nil, call `assert' on FORM. +This is used instead of `assert' when FORM is expensive to compute +and shouldn't be run normally." + `(when good-scroll--debug + (cl-assert ,form))) + +(defun good-scroll--point-at-top-p () + "Return non-nil if the point is close to the top of the selected window." + (save-restriction + ;; Widen in case the window start is outside the visible part of the buffer + (widen) + (<= (line-number-at-pos (point) t) + (1+ (line-number-at-pos (window-start) t))))) + +(defun good-scroll--advice-line-move (line-move &rest args) + "Call LINE-MOVE with ARGS, but avoid resetting the vscroll. +This function is used as advice to the `line-move' function." + (if (good-scroll--point-at-top-p) + ;; If point is at the top, + ;; default to the old behavior of resetting the vscroll. + ;; It makes sense to show the full top line when the point moves up. + (apply line-move args) + ;; Use dynamic scoping to bind function + ;; https://endlessparentheses.com/understanding-letf-and-how-it-replaces-flet.html + (cl-letf (((symbol-function #'set-window-vscroll) #'ignore)) + (apply line-move args)))) + +(defun good-scroll-up (&optional _delta) + "Scroll up one step. +The value of DELTA is ignored and exists only for compatibility with +`mwheel-scroll-up-function'." + (interactive) + (good-scroll-move good-scroll-step)) + +(defun good-scroll-down (&optional _delta) + "Scroll down one step. +The value of DELTA is ignored and exists only for compatibility with +`mwheel-scroll-down-function'." + (interactive) + (good-scroll-move (- good-scroll-step))) + +(defun good-scroll-up-full-screen () + "Scroll up by a full screen." + (interactive) + (good-scroll-move (good-scroll--window-usable-height))) + +(defun good-scroll-down-full-screen () + "Scroll down by a full screen." + (interactive) + (good-scroll-move (- (good-scroll--window-usable-height)))) + +(defun good-scroll-move (step) + "Begin a scroll of STEP pixel lines. +A negative STEP means to scroll down. This is a helper function for +`good-scroll-up' and `good-scroll-down'." + (unless (input-pending-p) + (setq good-scroll-destination + (+ step + ;; Reset destination if scroll changed direction + (if (> (* step good-scroll-direction) 0) + good-scroll-destination + 0)) + good-scroll-start-time (float-time) + good-scroll-traveled 0 + good-scroll-direction step + good-scroll--window (selected-window)))) + +(defun good-scroll--cached-point-top-dirty-p () + "Return t if the point moved or window scrolled since the last render. +Otherwise, return nil. +If the point moved or window scrolled since the last render, +this leads to `good-scroll--cached-point-top' being invalidated." + (not (and good-scroll--prev-vscroll + good-scroll--prev-point + (= good-scroll--prev-point (point)) + (= good-scroll--prev-vscroll (window-vscroll nil t)) + (good-scroll--window-and-window-start-same-p)))) + +(defun good-scroll--render () + "Render an in-progress scroll. +Update the window's vscroll and position in the buffer based on the scroll +progress. This is called by the timer `good-scroll--timer' every +`good-scroll-render-rate' seconds." + ;; Check if the window that recieved the scroll event still exists and + ;; if there is distance to scroll. + (when (and (window-valid-p good-scroll--window) + (not (zerop good-scroll-destination))) + (let ((inhibit-redisplay t)) ; TODO: Does this do anything? + ;; Switch to the window that recieved the scroll event, + ;; which might be different from the previously selected window. + (with-selected-window good-scroll--window + (let ((position-next-try + (funcall good-scroll-algorithm)) + (position-next-actual)) + (cl-assert (<= (abs position-next-try) + (abs good-scroll-destination))) + (when (good-scroll--cached-point-top-dirty-p) + (setq good-scroll--cached-point-top nil)) + (setq position-next-actual (good-scroll--go-to position-next-try)) + (setq good-scroll-traveled (+ good-scroll-traveled + position-next-actual) + good-scroll-destination (- good-scroll-destination + position-next-actual) + good-scroll--prev-point (point) + good-scroll--prev-window-start (window-start) + good-scroll--prev-vscroll (window-vscroll nil t)) + ;; If we didn't jump the position as much as we wanted, + ;; then we must be trying to scroll past the edge of the buffer. + ;; This interrupts the scroll, so reset the destination to zero. + (when (/= position-next-try position-next-actual) + (setq good-scroll-destination 0))))))) + +(defun good-scroll--first-y () + "Return the cursor's first possible pixel y coordinate. +The return value is the number of pixels from top of window +to area below the tab and header lines, if any." + (+ (window-tab-line-height) (window-header-line-height))) + +(defun good-scroll--point-top () + "Return the pixel coordinate y-value of the top of the cursor. +This is the distance from the top of the usable part of the window +to the top of the cursor. +The usable part of the window is the area where the cursor is allowed to be: +below the tab and header lines." + ;; Distance from top of usable part of window + ;; to topmost visible part of the cursor. + ;; The actual top of the cursor might be above this if the top of the window + ;; overlaps the cursor. + (let* ((p-vis-top (- (nth 1 (pos-visible-in-window-p nil nil t)) + (good-scroll--first-y)))) + (if (zerop p-vis-top) + ;; If the visible part of the cursor is at the top, + ;; a nonzero vscroll can make the real top of the cursor + ;; above the top of the usable part of the window. + (- p-vis-top (window-vscroll nil t)) + p-vis-top))) + +(defun good-scroll--move-point-up () + "Move the cursor up and update `good-scroll--cached-point-top' accordingly." + (when (= -1 (vertical-motion -1)) + (setq good-scroll--cached-point-top + (- good-scroll--cached-point-top (line-pixel-height))))) + +(defun good-scroll--move-point-down () + "Move the cursor down and update `good-scroll--cached-point-top' accordingly." + (let ((height (line-pixel-height))) + (if (= 1 (vertical-motion 1)) + (setq good-scroll--cached-point-top + (+ good-scroll--cached-point-top height)) + ;; If point is on the last line, + ;; `vertical-motion' moves it to the end of the line. + ;; This causes a jitter, so avoid it. + (beginning-of-line)))) + +(defun good-scroll--window-usable-height () + "Return the usable height of the selected window. +Return the pixel height of the area of the selected window +that the cursor is allowed to be inside. +This is from the bottom of the header line to the top of the mode line." + (let* ((w-edges (window-inside-pixel-edges)) + ;; Number of pixels from top of frame to top of selected window + ;; The top of the window is considered the top of the tab line, + ;; if it exists. + (w-top (- (nth 1 w-edges) (window-header-line-height))) + ;; Number of pixels from top of frame to bottom of selected window + ;; The bottom of the window is considered the top of the mode line. + (w-bottom (+ (nth 3 w-edges) (window-tab-line-height)))) + (- w-bottom w-top (good-scroll--first-y)))) + +(defun good-scroll--move-point-out-of-way (delta) + "Move the cursor to prepare for a scroll of DELTA pixel lines. +Emacs doesn't allow the cursor to be outside the window, +so move it as little as possible to avoid this. +Return t if the cursor moved, nil otherwise. +This function only moves the point by one line at a time, +so it should be called while it returns t." + (let* ((p-start (point)) ; Cursor position + (w-usable-height (good-scroll--window-usable-height)) + ;; Number of pixels from top of window to top of cursor + ;; This can be negative if the top of the window overlaps the cursor. + (p-top (setq good-scroll--cached-point-top + (or good-scroll--cached-point-top + (good-scroll--point-top)))) + ;; Pixel height of cursor + (p-height (line-pixel-height)) + ;; Number of pixels from top of window to bottom of cursor + (p-bottom (+ p-top p-height)) + ;; Number of pixels from top of window to top of cursor, + ;; after scrolling `delta' pixel lines. + (p-next-top (- p-top delta)) + ;; Number of pixels from top of window to bottom of cursor, + ;; after scrolling `delta' pixel lines. + (p-next-bottom (- p-bottom delta)) + ;; Number of pixels from top of window to top of line below cursor + (nl-top p-bottom) + ;; Pixel height of line below cursor + (nl-height (save-excursion + (vertical-motion 1) + (line-pixel-height))) + ;; Number of pixels from top of window to bottom of line below cursor + (nl-bottom (+ nl-top nl-height)) + ;; Number of pixels from top of window to bottom of line below cursor, + ;; after scrolling `delta' pixel lines. + (nl-next-bottom (- nl-bottom delta))) + (good-scroll--log "R1" + good-scroll--cached-point-top + (good-scroll--point-top)) + (good-scroll--slow-assert (= good-scroll--cached-point-top + (good-scroll--point-top))) + (cond + ;; The scroll is going to make the bottom of the cursor + ;; go below the bottom of the window. + ;; Move it up to avoid this. + ;; The exception is when the cursor height + ;; is greater than the window height. + ((and (> p-next-bottom w-usable-height) (> w-usable-height p-height)) + (good-scroll--log "move point out of way case 1") + (good-scroll--move-point-up)) + ;; The scroll is going to make the bottom of the cursor go above the window, + ;; which would make the cursor go completely offscreen. + ;; Move the cursor down to avoid this. + ((<= p-next-bottom 0) + (good-scroll--log "move point out of way case 2") + (good-scroll--move-point-down)) + ;; The scroll is going to make the cursor overlap the top of the window. + ;; Move the cursor down to avoid this if there's room. + ((and (< p-next-top 0 p-next-bottom) (<= nl-next-bottom w-usable-height)) + (good-scroll--log "move point out of way case 3") + (good-scroll--move-point-down)) + ;; The cursor is not going to overlap the top of the window + ;; and the cursor height is greater than the window height. + ;; Move the point up, because we want to maintain the property + ;; that when the cursor height exceeds the window height, + ;; there shouldn't be any space between the cursor + ;; and the top of the window. + ;; Breaking this property is inconsistent with case 1 + ;; and can prevent scrolling down. + ((and (not (< p-next-top 0 p-next-bottom)) (> p-height w-usable-height)) + (good-scroll--log "move point out of way case 4") + (good-scroll--move-point-up))) + ;; Return if the cursor position changed + (/= p-start (point)))) + +(defun good-scroll--go-to (target) + "Jump the window by TARGET pixel lines. +Update the window's vscroll and position in the buffer to instantly scroll to +TARGET, where TARGET is the index from the top of the window in pixel lines. +TARGET can be negative. +Return the number of pixels (possibly negative) scrolled successfully." + (while (good-scroll--move-point-out-of-way target)) + (good-scroll--log "cached-point-top assertion 2" + target + good-scroll--cached-point-top + (good-scroll--point-top)) + (good-scroll--slow-assert (= good-scroll--cached-point-top + (good-scroll--point-top))) + (let ((remaining target)) + (while + (let* ( + ;; Number of pixels scrolled past the top of the first line. + (vscroll (window-vscroll nil t)) + ;; Pixel height of the first line + (line-height (save-excursion + (goto-char (window-start)) + (line-pixel-height))) + ;; Remaining number of pixels in the first line + (line-remaining (- line-height vscroll)) + (prev-remaining remaining)) + (setq remaining + (cond + ((> remaining 0) (good-scroll--go-to-up remaining + vscroll + line-height + line-remaining)) + ((< remaining 0) (good-scroll--go-to-down remaining vscroll)) + (t remaining))) + (/= remaining prev-remaining))) + (let ((traveled (- target remaining))) + (setq good-scroll--cached-point-top + (- good-scroll--cached-point-top traveled)) + (good-scroll--log "R3" + traveled + target + remaining + good-scroll--cached-point-top + (good-scroll--point-top)) + (good-scroll--slow-assert (= good-scroll--cached-point-top + (good-scroll--point-top))) + traveled))) + +(defun good-scroll--go-to-up (pos vscroll line-height rem) + "Partially jump the window up by POS pixel lines. +Return the remaining number of pixel lines to scroll. + +The parameter VSCROLL is the selected window's vscroll, +LINE-HEIGHT is the height in pixels of the first line in the selected window, +and REM is the number of pixel lines from the vscroll to the end of the first +line in the selected window." + (good-scroll--log "good-scroll--go-to-up" + pos + vscroll + line-height + rem + (window-start) + good-scroll--cached-point-top + (good-scroll--point-top)) + (if (< (+ vscroll pos) line-height) + ;; Done scrolling except for a fraction of a line. + ;; Scroll a fraction of a line and terminate. + (good-scroll--go-to-up-partial pos vscroll) + ;; Scroll a full line + (good-scroll--go-to-up-full pos rem))) + +(defun good-scroll--go-to-up-partial (pos vscroll) + "Increase the current window's vscroll by POS pixels. +Return zero. Assume VSCROLL + POS is less than the pixel height of the current +line and the current window's vscroll is VSCROLL." + (good-scroll--log "good-scroll--go-to-up-partial before" + pos + vscroll + good-scroll--cached-point-top + (good-scroll--point-top)) + (set-window-vscroll nil (+ vscroll pos) t) + (good-scroll--log "good-scroll--go-to-up-partial after" + (good-scroll--point-top)) + 0) + + +(defun good-scroll--go-to-up-full (pos rem) + "Scroll the screen up by a full line. +Return the next target scroll position. Assume POS > REM, where REM is the +remaining amount of pixels from the top of the screen to the end of the top +line." + (good-scroll--log "good-scroll--go-to-up-full" + pos + rem + (window-start) + good-scroll--cached-point-top + (good-scroll--point-top)) + ;; Are we at the end of the buffer? + (if (= (line-number-at-pos (point-max)) + (line-number-at-pos (window-start))) + ;; We are! + ;; Print a message and terminate. + (progn + (message (get #'end-of-buffer 'error-message)) + pos) + ;; We aren't. + ;; Actually scroll one line + (set-window-vscroll nil 0 t) + (set-window-start nil (save-excursion + (goto-char (window-start)) + (vertical-motion 1) + (point)) + t) + (good-scroll--log "good-scroll--go-to-up-full after" + (window-start) + good-scroll--cached-point-top + (good-scroll--point-top)) + (- pos rem))) + +(defun good-scroll--go-to-down (pos vscroll) + "Partially jump the window down by POS pixel lines. +Return the remaining number of pixel lines to scroll. The parameter VSCROLL is +the selected window's vscroll." + (good-scroll--log "good-scroll--go-to-down" + pos + vscroll + good-scroll--cached-point-top + (good-scroll--point-top)) + (if (<= (- pos) vscroll) + ;; Done scrolling except for a fraction of a line. + ;; Scroll a fraction of a line and terminate. + (good-scroll--go-to-down-partial pos vscroll) + ;; Scroll a full line + (good-scroll--go-to-down-full pos vscroll))) + +(defun good-scroll--go-to-down-partial (pos vscroll) + "Change the current window's vscroll by POS pixels. +Return zero. Assume -POS <= VSCROLL." + (good-scroll--log "good-scroll--go-to-down-partial before" + pos + vscroll + good-scroll--cached-point-top + (good-scroll--point-top)) + (set-window-vscroll nil (+ vscroll pos) t) + (good-scroll--log "good-scroll--go-to-down-partial after" + (good-scroll--point-top)) + 0) + +(defun good-scroll--go-to-down-full (pos vscroll) + "Scroll the screen down by a full line. +Return the next target scroll position. Assume POS > VSCROLL." + (good-scroll--log "good-scroll--go-to-down-full before" + pos + vscroll + good-scroll--cached-point-top + (good-scroll--point-top)) + (set-window-vscroll nil 0 t) + ;; Are we at the beginning of the buffer? + (if (= (line-number-at-pos (point-min)) + (line-number-at-pos (window-start))) + ;; We are! + ;; Print a message and terminate. + (progn + (message (get #'beginning-of-buffer 'error-message)) + (+ pos vscroll)) + (good-scroll--log "good-scroll--go-to-down-full mid" + (good-scroll--point-top)) + ;; We aren't. + ;; Actually scroll one line + (set-window-start nil (save-excursion + (goto-char (window-start)) + (vertical-motion -1) + (point)) + t) + (good-scroll--log "good-scroll--go-to-down-full after" + (good-scroll--point-top)) + (+ pos vscroll + (save-excursion + (goto-char (window-start)) + (line-pixel-height))))) + +(provide 'good-scroll) + +;;; good-scroll.el ends here diff --git a/homebase/public/.emacs.d/locext/iscroll/LICENSE b/homebase/public/.emacs.d/locext/iscroll/LICENSE new file mode 100644 index 00000000..e72bfdda --- /dev/null +++ b/homebase/public/.emacs.d/locext/iscroll/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. \ No newline at end of file diff --git a/homebase/public/.emacs.d/locext/iscroll/README.org b/homebase/public/.emacs.d/locext/iscroll/README.org new file mode 100644 index 00000000..2e50c4dd --- /dev/null +++ b/homebase/public/.emacs.d/locext/iscroll/README.org @@ -0,0 +1,30 @@ +#+TITLE: Iscroll.el + +[[https://melpa.org/#/iscroll][file:https://melpa.org/packages/iscroll-badge.svg]] + +[[https://casouri.github.io/iscroll/demo.gif][Screencast]] + +Gone are the days when images jumps in and out of the window when scrolling! This package provides smooth scrolling over images. + +Due to some technical problems, the code is not merging into Emacs in the near futher. When it finally does merge, this package can retire. + +To use this package: + +#+begin_src +M-x iscroll-mode RET +#+end_src + +This mode remaps mouse scrolling functions and ~next/previous-line~. If you use other commands, you need to adapt them accordingly. See ~iscroll-mode-map~ and ~iscroll-mode~ for some inspiration. + +~iscroll-mode~ is kind of slow in programming modes, but fast in text modes. So I suggest to only enable it in text modes. + +* Commands + +- iscroll-up +- iscroll-down +- iscroll-next-line +- iscroll-previous-line + +* Evil mode + +Iscroll.el doesn’t work with Evil out-of-the-box. You need to add some boilerplate. diff --git a/homebase/public/.emacs.d/locext/iscroll/iscroll.el b/homebase/public/.emacs.d/locext/iscroll/iscroll.el new file mode 100644 index 00000000..55e4deed --- /dev/null +++ b/homebase/public/.emacs.d/locext/iscroll/iscroll.el @@ -0,0 +1,310 @@ +;;; iscroll.el --- Smooth scrolling over images -*- lexical-binding: t; -*- + +;; Author: Yuan Fu +;; Maintainer: Yuan Fu +;; URL: https://github.com/casouri/iscroll +;; Version: 1.0.0 +;; Keywords: convenience, image +;; Package-Requires: ((emacs "26.0")) + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; +;; Gone are the days when images jumps in and out of the window when +;; scrolling! This package makes scrolling over images as if the image +;; is made of many lines, instead of a single line. (Indeed, sliced +;; image with default scrolling has the similar behavior as what this +;; package provides.) +;; +;; To use this package: +;; +;; M-x iscroll-mode RET +;; +;; This mode remaps mouse scrolling functions and `next/previous-line'. +;; If you use other commands, you need to adapt them accordingly. See +;; `iscroll-mode-map' and `iscroll-mode' for some inspiration. +;; +;; You probably don't want to enable this in programming modes because +;; it is slower than normal scrolling commands. +;; +;; If a line is taller than double the default line height, smooth +;; scrolling is triggered and Emacs will reveal one line’s height each +;; time. +;; +;; Commands provided: +;; +;; - iscroll-up +;; - iscroll-down +;; - iscroll-next-line +;; - iscroll-previous-line +;; + +;;; Code: +;; + +(require 'cl-lib) + +(defvar iscroll-preserve-screen-position + scroll-preserve-screen-position + "Whether to preserve screen position when scrolling. +\(I want to control this behavior for iscroll separately.)") + +(defun iscroll-up (&optional arg) + "Scroll up ARG lines. +Normally just calls `scroll-up'. But if the top of the window is +an image, scroll inside the image. Return the number of logical +lines scrolled." + (interactive "p") + (let ((arg (or arg 1)) + (display-lines-scrolled 0) + (original-point (point)) + (scroll-amount nil) + (need-to-recalculate-img-height t) + (preserve-screen-pos iscroll-preserve-screen-position) + img-height + hit-end-of-buffer) + ;; 1) We first do a dry-run: not actually scrolling, just moving + ;; point and modifying SCROLL-AMOUNT. + (goto-char (window-start)) + (while (> arg 0) + ;; Initialize SCROLL-AMOUNT when we arrived at a new line or + ;; first entered the command. + (when (null scroll-amount) + (setq scroll-amount (window-vscroll nil t))) + ;; `line-pixel-height' is expensive so we try to call it as less + ;; as possible. + (when need-to-recalculate-img-height + (setq img-height (line-pixel-height) + need-to-recalculate-img-height nil)) + ;; Scroll. + (if (and (>= img-height (* 2 (default-line-height))) + (< scroll-amount img-height)) + ;; If we are in the middle of scrolling an image, scroll + ;; that image. + (setq scroll-amount + (min (+ scroll-amount (default-line-height)) + img-height)) + ;; If we are not on an image or the image is scrolled over, + ;; scroll display line. + (cl-incf display-lines-scrolled) + (setq need-to-recalculate-img-height t) + ;; We hit the end of buffer, stop. + (when (not (eq (vertical-motion 1) 1)) + (setq hit-end-of-buffer t) + (setq arg 0)) + (setq scroll-amount nil)) + (cl-decf arg)) + ;; 2) Finally, we’ve finished the dry-run, apply the result. + ;; + ;; The third argument `t' tells redisplay that (point) doesn't + ;; have to be the window start and completely visible. That + ;; allows our vscroll value to survive. + (set-window-start nil (point) t) + (if scroll-amount + (set-window-vscroll nil scroll-amount t) + (set-window-vscroll nil 0 t)) + ;; 3) Misc stuff. + ;; + ;; If the original point is after window-start, it is in the + ;; visible portion of the window, and is safe to go back to. + (if (> original-point (window-start)) + (goto-char original-point) + ;; If not, we just stay at current position, i.e. window-start. + (setq preserve-screen-pos nil)) + ;; (Maybe) move point to preserve screen position. + (when preserve-screen-pos + (vertical-motion display-lines-scrolled)) + ;; Show “error message”. + (when hit-end-of-buffer + (message "%s" (error-message-string '(end-of-buffer)))) + display-lines-scrolled)) + +(defun iscroll-down (&optional arg) + "Scroll down ARG lines. +Normally just calls `scroll-down'. But if the top of the window is +an image, scroll inside the image. Return the number of logical +lines scrolled. If PRESERVE-SCREEN-POS non-nil, try to preserve +screen position." + (interactive "p") + (let ((arg (or arg 1)) + (display-lines-scrolled 0) + (original-point (point)) + ;; Nil means this needs to re-measured. + (scroll-amount nil) + (preserve-screen-pos iscroll-preserve-screen-position) + hit-beginning-of-buffer) + ;; 1) Dry-run. + (goto-char (window-start)) + (while (> arg 0) + (when (null scroll-amount) + (setq scroll-amount (window-vscroll nil t))) + (let ((img-height (line-pixel-height))) + (if (and (>= img-height (* 2 (default-line-height))) + (> scroll-amount 0)) + ;; Scroll image. + (setq scroll-amount + (- scroll-amount (default-line-height))) + ;; Scroll display line. + (when (not (eq (vertical-motion -1) -1)) + ;; If we hit the beginning of buffer, stop. + (setq hit-beginning-of-buffer t + arg 0)) + (cl-incf display-lines-scrolled) + ;; If the line we stopped at is an image, we don't want to + ;; show it completely, instead, modify vscroll and only + ;; show a bottom strip of it. If we are at the beginning + ;; of the buffer and `vertical-motion' returns 0, we don't + ;; want to do this. + (let ((img-height (line-pixel-height))) + (if (>= img-height (* 2 (default-line-height))) + (setq scroll-amount (- img-height (default-line-height))) + (setq scroll-amount nil))))) + (cl-decf arg)) + ;; 2) Apply result. + (set-window-start nil (point) t) + (if scroll-amount + (set-window-vscroll nil scroll-amount t) + (set-window-vscroll nil 0 t)) + ;; 3) Misc + ;; + ;; HACK: There is no fast and reliable way to get the last visible + ;; point, hence this hack: move point up until it is visible. + (goto-char original-point) + ;; Checking point > window-start is important, otherwise we could + ;; fall into infinite loop. E.g., when point = window-start and + ;; under the point is an image that is not completely visible. + (while (and (> (point) (window-start)) + (not (pos-visible-in-window-p (point)))) + (setq preserve-screen-pos nil) + (vertical-motion -2)) + (when (and preserve-screen-pos (not hit-beginning-of-buffer)) + (vertical-motion (- display-lines-scrolled))) + (when hit-beginning-of-buffer + (message "%s" (error-message-string '(beginning-of-buffer)))) + display-lines-scrolled)) + +(defvar iscroll--goal-column nil + "Goal column when scrolling.") + +(defun iscroll--current-column () + "Return the current column of point in current screen line. +‘current-column’ counts columns from logical line beginning, this +function counts from visual line beginning." + (save-excursion + (let ((col (current-column))) + ;; Go to visual line beginning. + (vertical-motion 0) + (- col (current-column))))) + +(defun iscroll-forward-line (&optional arg) + "Smooth `forward-line'. +ARG is the number of lines to move." + (interactive "^p") + (let* ((arg (or arg 1)) + (abs-arg (abs arg)) + (step (if (> arg 0) 1 -1)) + (scroll-fn (if (> arg 0) + #'iscroll-up + #'iscroll-down)) + (old-point (point)) + (first-command-p (not (memq last-command + '(iscroll-next-line + iscroll-previous-line)))) + ;; Calculate the goal column. The goal column is either + ;; inherited from previous calls to this command, or + ;; calculated by visual column. + (goal-column (if (or first-command-p (not iscroll--goal-column)) + (setq iscroll--goal-column + (iscroll--current-column)) + (or iscroll--goal-column 0))) + ;; We don't want to preserve screen position when moving point. + (iscroll-preserve-screen-position nil) + hit-boundary) + ;; Because in most cases we move into visible portions, we move + ;; first and check after, this should be faster than check first + ;; and move after. + (while (> abs-arg 0) + ;; Move point. `move-to-column' counts columns from logical line + ;; beginnings and `vertical-motion' counts columns from visual + ;; beginnings. So `vertical-motion' works with line-wrapping but + ;; `move-to-column' does not. + (when (not (eq (vertical-motion (cons iscroll--goal-column step)) + step)) + ;; If we hit beginning or end of buffer, stop. + (setq hit-boundary t + abs-arg 0)) + (when (not (pos-visible-in-window-p (point))) + ;; The new point is not fully visible! Scroll up/down one line + ;; to try to accommodate that line. + (funcall scroll-fn 1)) + ;; We scrolled one line but that line is still not fully + ;; visible, move the point back so that redisplay doesn’t force + ;; the whole line into visible region. Partially visible is ok, + ;; completely invisible is not ok. + (when (and (not (pos-visible-in-window-p (point))) + ;; If the image is taller than the window and is the + ;; first row of the window, it is ok to leave point + ;; on it. + (<= (line-pixel-height) (window-text-height nil t))) + (goto-char old-point) + (setq hit-boundary nil)) + (cl-decf abs-arg)) + ;; If we hit buffer boundary and didn’t back off, show “error + ;; message”. + (when hit-boundary + (message "%s" (error-message-string + (list (if (> arg 0) + 'end-of-buffer + 'beginning-of-buffer))))))) + +(defun iscroll-next-line (&optional arg _) + "Smooth `next-line'. +ARG is the number of lines to move." + (interactive "^p") + (iscroll-forward-line arg)) + +(defun iscroll-previous-line (&optional arg _) + "Smooth `previous-line'. +ARG is the number of lines to move." + (interactive "^p") + (iscroll-forward-line (- (or arg 1)))) + +(defvar iscroll-mode-map (make-sparse-keymap) + "Minor mode map for `iscroll-mode'.") + +;;;###autoload +(define-minor-mode iscroll-mode + "Smooth scrolling over images." + :lighter " IS" + :keymap iscroll-mode-map + :group 'scrolling + (if iscroll-mode + (progn + (setq-local mwheel-scroll-up-function #'iscroll-up + mwheel-scroll-down-function #'iscroll-down) + ;; We don’t remap next/previous-line in the minor mode map + ;; because that shallows ivy’s binding. + (local-set-key [remap next-line] #'iscroll-next-line) + (local-set-key [remap previous-line] #'iscroll-previous-line)) + (kill-local-variable 'mwheel-scroll-up-function) + (kill-local-variable 'mwheel-scroll-down-function) + (local-set-key [remap next-line] nil) + (local-set-key [remap previous-line] nil))) + +(provide 'iscroll) + +;;; iscroll.el ends here diff --git a/homebase/public/.emacs.d/locext/isearch-mb/README.org b/homebase/public/.emacs.d/locext/isearch-mb/README.org new file mode 100644 index 00000000..3e90496f --- /dev/null +++ b/homebase/public/.emacs.d/locext/isearch-mb/README.org @@ -0,0 +1,140 @@ +#+title: isearch-mb --- Control isearch from the minibuffer + +#+html:

GNU ELPA

+ +This Emacs package provides an alternative isearch UI based on the +minibuffer. This allows editing the search string in arbitrary ways +without any special maneuver; unlike standard isearch, cursor motion +commands do not end the search. Moreover, the search status +information in the echo area and some keybindings are slightly +simplified. + +isearch-mb is part of [[https://elpa.gnu.org/packages/isearch-mb.html][GNU ELPA]] and can be installed with +=M-x package-install RET isearch-mb RET=. To activate it, type +=M-x isearch-mb-mode RET=. + +** Keybindings + +During a search, =isearch-mb-minibuffer-map= is active. By default, it +includes the following commands: + +- =C-s=, =↓=: Repeat search forwards. +- =C-r=, =↑=: Repeat search backwards. +- =M-<=: Go to first match (or /n/-th match with numeric argument). +- =M->=: Go to last match (or /n/-th last match with numeric argument). +- =C-v=, ==: Search forward from the bottom of the window. +- =M-v=, ==: Search backward from the top of the window. +- =M-%=: Replace occurrences of the search string. +- =C-M-%=: Replace occurrences of the search string (regexp mode). +- =M-s= prefix: similar to standard isearch. + +Everything else works as in a plain minibuffer. For instance, =RET= +ends the search normally and =C-g= cancels it. + +** Some customization ideas + +isearch provides a myriad of customization options, and most of them +make just as much sense when using isearch-mb. The following are some +uncontroversial improvements of the defaults: + +#+begin_src emacs-lisp + (setq-default + ;; Show match count next to the minibuffer prompt + isearch-lazy-count t + ;; Don't be stingy with history; default is to keep just 16 entries + search-ring-max 200 + regexp-search-ring-max 200) +#+end_src + +Note that since isearch-mb relies on a regular minibuffer, you can use +you favorite tool to browse the history of previous search strings +(say, the =consult-history= command from the excellent [[https://github.com/minad/consult][Consult]] +package). + +Using regexp search by default is a popular option as well: + +#+begin_src emacs-lisp + (global-set-key (kbd "C-s") 'isearch-forward-regexp) + (global-set-key (kbd "C-r") 'isearch-backward-regexp) +#+end_src + +Another handy option is to enable lax whitespace matching in one of +the two variations indicated below. You can still toggle strict +whitespace matching with =M-s SPC= during a search, or escape a space +with a backslash to match it literally. + +#+begin_src emacs-lisp + (setq-default + isearch-regexp-lax-whitespace t + ;; Swiper style: space matches any sequence of characters in a line. + search-whitespace-regexp ".*?" + ;; Alternative: space matches whitespace, newlines and punctuation. + search-whitespace-regexp "\\W+") +#+end_src + +Finally, you may want to check out the [[https://github.com/astoff/isearch-mb/wiki][isearch-mb wiki]] for additional +tips and tricks. + +** Interaction with other isearch extensions + +Some third-party isearch extensions require a bit of configuration in +order to work with isearch-mb. There are three cases to consider: + +- *Commands that start a search* in a special state shouldn't require + extra configuration. This includes PDF Tools, Embark, etc. + +- *Commands that operate during a search session* should be added to + the list =isearch-mb--with-buffer=. Examples of this case are + [[https://github.com/fourier/loccur#isearch-integration][=loccur-isearch=]] and [[https://github.com/minad/consult][=consult-isearch=]]. + + #+begin_src emacs-lisp + (add-to-list 'isearch-mb--with-buffer #'loccur-isearch) + (define-key isearch-mb-minibuffer-map (kbd "C-o") #'loccur-isearch) + + (add-to-list 'isearch-mb--with-buffer #'consult-isearch) + (define-key isearch-mb-minibuffer-map (kbd "M-r") #'consult-isearch) + #+end_src + + Most isearch commands that are not made available by default in + isearch-mb can also be used in this fashion: + + #+begin_src emacs-lisp + (add-to-list 'isearch-mb--with-buffer #'isearch-yank-word) + (define-key isearch-mb-minibuffer-map (kbd "M-s C-w") #'isearch-yank-word) + #+end_src + +- *Commands that end the isearch session* should be added to the list + =isearch-mb--after-exit=. Examples of this case are + [[https://github.com/abo-abo/avy][=avy-isearch=]] and [[https://github.com/minad/consult][=consult-line=]]: + + #+begin_src emacs-lisp + (add-to-list 'isearch-mb--after-exit #'avy-isearch) + (define-key isearch-mb-minibuffer-map (kbd "C-'") #'avy-isearch) + + (add-to-list 'isearch-mb--after-exit #'consult-line) + (define-key isearch-mb-minibuffer-map (kbd "M-s l") #'consult-line) + #+end_src + + Arranging for motion commands to quit the search, as in standard + isearch, is out of the scope of this package, but you can define + your own commands to emulate that effect. Here is one possibility: + + #+begin_src emacs-lisp + (defun move-end-of-line-maybe-ending-isearch (arg) + "End search and move to end of line, but only if already at the end of the minibuffer." + (interactive "p") + (if (eobp) + (isearch-mb--after-exit + (lambda () + (move-end-of-line arg) + (isearch-done))) + (move-end-of-line arg))) + + (define-key isearch-mb-minibuffer-map (kbd "C-e") 'move-end-of-line-maybe-ending-isearch) + #+end_src + +** Contributing + +Discussions, suggestions and code contributions are welcome! Since +this package is part of GNU ELPA, contributions require a copyright +assignment to the FSF. diff --git a/homebase/public/.emacs.d/locext/isearch-mb/isearch-mb.el b/homebase/public/.emacs.d/locext/isearch-mb/isearch-mb.el new file mode 100644 index 00000000..931b9953 --- /dev/null +++ b/homebase/public/.emacs.d/locext/isearch-mb/isearch-mb.el @@ -0,0 +1,279 @@ +;;; isearch-mb.el --- Control isearch from the minibuffer -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2024 Free Software Foundation, Inc. + +;; Author: Augusto Stoffel +;; URL: https://github.com/astoff/isearch-mb +;; Keywords: matching +;; Package-Requires: ((emacs "27.1")) +;; Version: 0.8 + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This package provides an alternative isearch UI based on the +;; minibuffer. This allows editing the search string in arbitrary +;; ways without any special maneuver; unlike standard isearch, cursor +;; motion commands do not end the search. Moreover, the search status +;; information in the echo area and some keybindings are slightly +;; simplified. + +;; To use the package, simply activate `isearch-mb-mode'. + +;;; Code: + +(eval-when-compile + (require 'cl-lib) + (require 'subr-x)) + +(defgroup isearch-mb nil + "Control isearch from the minibuffer." + :group 'isearch) + +(defvar isearch-mb--with-buffer + '(isearch-beginning-of-buffer + isearch-end-of-buffer + isearch-occur + isearch-repeat-backward + isearch-repeat-forward + isearch-toggle-case-fold + isearch-toggle-char-fold + isearch-toggle-invisible + isearch-toggle-lax-whitespace + isearch-toggle-regexp + isearch-toggle-symbol + isearch-toggle-word + isearch-exit + isearch-delete-char) + "List of commands to execute in the search buffer.") + +(defvar isearch-mb--after-exit + '(isearch-query-replace + isearch-query-replace-regexp + isearch-highlight-regexp + isearch-highlight-lines-matching-regexp + isearch-abort) + "List of commands to execute after exiting the minibuffer.") + +(defvar isearch-mb--no-search + '(next-history-element previous-history-element) + "List of commands that shouldn't trigger a search.") + +(defvar isearch-mb-minibuffer-map + (let ((map (make-composed-keymap nil minibuffer-local-map))) + (define-key map [remap next-line-or-history-element] #'isearch-repeat-forward) + (define-key map [remap previous-line-or-history-element] #'isearch-repeat-backward) + (define-key map [remap minibuffer-beginning-of-buffer] #'isearch-beginning-of-buffer) + (define-key map [remap end-of-buffer] #'isearch-end-of-buffer) + (define-key map [remap scroll-up-command] 'isearch-mb-scroll-up-command) + (define-key map [remap scroll-down-command] 'isearch-mb-scroll-down-command) + (define-key map [remap query-replace] #'isearch-query-replace) + (define-key map [remap query-replace-regexp] #'isearch-query-replace-regexp) + (define-key map "\C-j" #'newline) + (define-key map "\C-s" #'isearch-repeat-forward) + (define-key map "\C-r" #'isearch-repeat-backward) + (define-key map "\M-s'" #'isearch-toggle-char-fold) + (define-key map "\M-s " #'isearch-toggle-lax-whitespace) + (define-key map "\M-s_" #'isearch-toggle-symbol) + (define-key map "\M-sc" #'isearch-toggle-case-fold) + (define-key map "\M-shr" #'isearch-highlight-regexp) + (define-key map "\M-shl" #'isearch-highlight-lines-matching-regexp) + (define-key map "\M-si" #'isearch-toggle-invisible) + (define-key map "\M-so" #'isearch-occur) + (define-key map "\M-sr" #'isearch-toggle-regexp) + (define-key map "\M-sw" #'isearch-toggle-word) + map) + "Minibuffer keymap used by isearch-mb.") + +(defvar isearch-mb--prompt-overlay nil + "Overlay for minibuffer prompt updates.") + +;; Variables introduced in Emacs 28 +(defvar isearch-motion-changes-direction nil) +(defvar isearch-repeat-on-direction-change nil) +(defvar isearch-forward-thing-at-point '(region url symbol sexp)) + +(defun isearch-mb--after-change (_beg _end _len) + "Hook to run from the minibuffer to update the isearch state." + (let ((string (minibuffer-contents)) + (cursor-in-echo-area t)) + (with-minibuffer-selected-window + (setq isearch-string (substring-no-properties string)) + (isearch-update-from-string-properties string) + ;; Backtrack to barrier and search, unless `this-command' is + ;; special or the search regexp is invalid. + (if (or (and (symbolp this-command) + (memq this-command isearch-mb--no-search)) + (and isearch-regexp + (condition-case err + (prog1 nil (string-match-p isearch-string "")) + (invalid-regexp + (prog1 t (setq isearch-error (cadr err))))))) + (isearch-update) + (goto-char isearch-barrier) + (setq isearch-adjusted t isearch-success t) + (isearch-search-and-update))))) + +(defun isearch-mb--post-command-hook () + "Hook to make the minibuffer reflect the isearch state." + (unless isearch--current-buffer + (throw 'isearch-mb--continue '(ignore))) + (let ((inhibit-modification-hooks t)) + ;; We never update `isearch-message'. If it's not empty, then + ;; isearch changed the search string on its own volition. + (unless (string-empty-p isearch-message) + (setq isearch-message "") + (delete-minibuffer-contents) + (insert isearch-string)) + (set-text-properties (minibuffer-prompt-end) (point-max) nil) + (when-let ((fail-pos (isearch-fail-pos))) + (add-text-properties (+ (minibuffer-prompt-end) fail-pos) + (point-max) + '(face isearch-fail))) + (when isearch-error + (isearch-mb--message isearch-error)))) + +(defun isearch-mb--message (message) + "Display a momentary MESSAGE." + (let ((message-log-max nil)) + (message (propertize (concat " [" message "]") + 'face 'minibuffer-prompt)))) + +(defun isearch-mb--update-prompt (&rest _) + "Update the minibuffer prompt according to search status." + (when isearch-mb--prompt-overlay + (let ((count (isearch-lazy-count-format)) + (len (or (overlay-get isearch-mb--prompt-overlay 'isearch-mb--len) 0))) + (overlay-put isearch-mb--prompt-overlay + 'isearch-mb--len (max len (length count))) + (overlay-put isearch-mb--prompt-overlay + 'before-string + (concat count ;; Count is padded so that it only grows. + (make-string (max 0 (- len (length count))) ?\ ) + (capitalize + (or (isearch--describe-regexp-mode + isearch-regexp-function) + ""))))))) + +(defun isearch-mb--add-defaults () + "Add default search strings to future history." + (setq minibuffer-default + (with-minibuffer-selected-window + (thread-last isearch-forward-thing-at-point + (mapcar #'thing-at-point) + (delq nil) + (delete-dups) + (mapcar (if isearch-regexp 'regexp-quote 'identity)))))) + +(defun isearch-mb--with-buffer (&rest args) + "Evaluate ARGS in the search buffer. +Intended as an advice for isearch commands." + (if (minibufferp) + (let ((enable-recursive-minibuffers t) + (cursor-in-echo-area t)) + (with-minibuffer-selected-window + (apply args))) + (apply args))) + +;; Special motion commands normally handled in `isearch-pre-command-hook'. +(dolist (symbol '(scroll-up-command scroll-down-command)) + (defalias (intern (concat "isearch-mb-" (symbol-name symbol))) + (let ((fun (pcase (get symbol 'isearch-motion) + (`(,motion . ,direction) + (lambda () + (let ((current-direction (if isearch-forward 'forward 'backward))) + (funcall motion) + (setq isearch-just-started t) + (let ((isearch-repeat-on-direction-change nil)) + (isearch-repeat direction) + (when (and isearch-success + (not isearch-motion-changes-direction) + (not (eq direction current-direction))) + (isearch-repeat current-direction)))))) + (_ symbol)))) ;; Emacs < 28 + (lambda () (interactive) (isearch-mb--with-buffer fun))) + (format "Perform motion of `%s' in the search buffer." symbol))) + +(defun isearch-mb--after-exit (&rest args) + "Evaluate ARGS after quitting isearch-mb. +Intended as an advice for commands that quit isearch and use the +minibuffer." + (throw 'isearch-mb--continue args)) + +(defun isearch-mb--session () + "Read search string from the minibuffer." + (remove-hook 'pre-command-hook 'isearch-pre-command-hook) + (remove-hook 'post-command-hook 'isearch-post-command-hook) + (setq overriding-terminal-local-map nil) + (condition-case nil + (apply + (catch 'isearch-mb--continue + (cl-letf (((cdr isearch-mode-map) nil) + ((symbol-function #'isearch--momentary-message) #'isearch-mb--message) + ;; Setting `isearch-message-function' currently disables lazy + ;; count, so we need this as a workaround. + ((symbol-function #'isearch-message) #'isearch-mb--update-prompt) + (minibuffer-default-add-function #'isearch-mb--add-defaults) + (wstart nil)) + (minibuffer-with-setup-hook + (lambda () + (add-hook 'after-change-functions #'isearch-mb--after-change nil 'local) + (add-hook 'post-command-hook #'isearch-mb--post-command-hook nil 'local) + (add-hook 'minibuffer-exit-hook + (lambda () (setq wstart (window-start (minibuffer-selected-window)))) + nil 'local) + (setq-local tool-bar-map isearch-tool-bar-map) + (setq isearch-mb--prompt-overlay (make-overlay (point-min) (point-min) + (current-buffer) t t)) + (isearch-mb--update-prompt) + (isearch-mb--post-command-hook)) + (unwind-protect + (progn + (dolist (fun isearch-mb--with-buffer) + (advice-add fun :around #'isearch-mb--with-buffer)) + (dolist (fun isearch-mb--after-exit) + (advice-add fun :around #'isearch-mb--after-exit)) + (read-from-minibuffer + "I-search: " nil isearch-mb-minibuffer-map nil + (if isearch-regexp 'regexp-search-ring 'search-ring) nil t) + ;; Undo a possible recenter after quitting the minibuffer. + (set-window-start nil wstart)) + (dolist (fun isearch-mb--after-exit) + (advice-remove fun #'isearch-mb--after-exit)) + (dolist (fun isearch-mb--with-buffer) + (advice-remove fun #'isearch-mb--with-buffer)))) + (if isearch-mode '(isearch-done) '(ignore))))) + (quit (if isearch-mode (isearch-cancel) (signal 'quit nil))))) + +(defun isearch-mb--setup () + "Arrange to start isearch-mb after this command, if applicable." + (unless (minibufferp) + ;; When `with-isearch-suspended' is involved, this hook may run + ;; more than once, hence the test for `isearch-mode'. + (run-with-idle-timer 0 nil (lambda () (when isearch-mode (isearch-mb--session)))))) + +;;;###autoload +(define-minor-mode isearch-mb-mode + "Control isearch from the minibuffer. + +During an isearch-mb session, the following keys are available: +\\{isearch-mb-minibuffer-map}" + :global t + (if isearch-mb-mode + (add-hook 'isearch-mode-hook #'isearch-mb--setup) + (remove-hook 'isearch-mode-hook #'isearch-mb--setup))) + +(provide 'isearch-mb) +;;; isearch-mb.el ends here diff --git a/homebase/public/.emacs.d/locext/org-modern/.gitignore b/homebase/public/.emacs.d/locext/org-modern/.gitignore new file mode 100644 index 00000000..d00328a1 --- /dev/null +++ b/homebase/public/.emacs.d/locext/org-modern/.gitignore @@ -0,0 +1,8 @@ +*-autoloads.el +*-pkg.el +*.elc +*.info +*.texi +*~ +\#*\# +/README-elpa diff --git a/homebase/public/.emacs.d/locext/org-modern/CHANGELOG.org b/homebase/public/.emacs.d/locext/org-modern/CHANGELOG.org new file mode 100644 index 00000000..fa4bc657 --- /dev/null +++ b/homebase/public/.emacs.d/locext/org-modern/CHANGELOG.org @@ -0,0 +1,44 @@ +#+title: org-modern.el - Changelog +#+author: Daniel Mendler +#+language: en + +* Development + +- Add support for heading folding indicators. The option ~org-modern-star~ has + been changed to accept the values ~fold~, ~replace~ and ~nil~. +- Add new customization options ~org-modern-replace-stars~ and + ~org-modern-fold-stars~. +- Add ~org-modern-tag-faces~. +- Add colored coded progress bars. The variable ~org-modern-progress~ specifies + the width of the bars. + +* Version 1.2 (2024-03-16) + +- =org-modern-star=, =org-modern-hide-stars=, =org-modern-progress=: Support string + values. + +* Version 1.1 (2023-12-01) + +- Bugfix: Do not use zero line width for box face attribute. Zero line widths + are disallowed in Emacs 30. + +* Version 1.0 (2023-12-01) + +- Bugfix: Remove line/wrap-prefix if fringe is enabled + +* Version 0.10 (2023-07-02) + +- Bugfixes. +- Fix star prettification if =org-indent-mode= is enabled. +- Prettify =filetags=. + +* Version 0.9 (2023-03-12) + +- Improve prettification of stars, such that line movement commands are not + affected negatively. +- Use =natnum= custom types. +- Depend on the Compat library. + +* Version 0.8 (2023-02-15) + +- Start of changelog. diff --git a/homebase/public/.emacs.d/locext/org-modern/LICENSE b/homebase/public/.emacs.d/locext/org-modern/LICENSE new file mode 100644 index 00000000..f288702d --- /dev/null +++ b/homebase/public/.emacs.d/locext/org-modern/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/homebase/public/.emacs.d/locext/org-modern/README.org b/homebase/public/.emacs.d/locext/org-modern/README.org new file mode 100644 index 00000000..bca63d63 --- /dev/null +++ b/homebase/public/.emacs.d/locext/org-modern/README.org @@ -0,0 +1,133 @@ +#+title: Modern Org Style +#+author: Daniel Mendler +#+language: en +#+export_file_name: org-modern.texi +#+texinfo_dir_category: Emacs misc features +#+texinfo_dir_title: Org-Modern: (org-modern). +#+texinfo_dir_desc: Modern Org Style + +#+html: GNU Emacs +#+html: GNU ELPA +#+html: GNU-devel ELPA +#+html: MELPA +#+html: MELPA Stable + +* Introduction + +This package implements a modern style for your Org buffers using font locking +and text properties. The package styles headlines, keywords, tables and source +blocks. The styling is configurable, you can enable, disable or modify the style +of each syntax element individually via the =org-modern= customization group. + +[[https://github.com/minad/org-modern/blob/screenshots/example.gif?raw=true]] + +The screenshots shows [[file:example.org][example.org]] with =org-modern-mode= turned on and off. The +elegant theme featured in the screenshot is [[https://protesilaos.com/emacs/modus-themes][modus-operandi]]. + +Since this package adjusts text styling, it depends on your font settings. You +should ensure that your =variable-pitch= and =fixed-pitch= fonts combine +harmonically and have approximately the same height. As default font, I +recommend variants of the [[https://github.com/be5invis/Iosevka][Iosevka]] font, e.g., Iosevka Term Curly. +=org-modern-mode= tries to adjust the tag label display based on the value of +=line-spacing=. This looks best if =line-spacing= has a value between 0.1 and 0.4 in +the Org buffer. + +* Configuration + +The package is available on GNU ELPA and MELPA. You can install the package with +=package-install=. Then =org-modern= can be enabled manually in an Org buffer by +invoking =M-x org-modern-mode=. In order to enable =org-modern= for all your Org +buffers, add =org-modern-mode= to the Org mode hooks. + +#+begin_src emacs-lisp +;; Option 1: Per buffer +(add-hook 'org-mode-hook #'org-modern-mode) +(add-hook 'org-agenda-finalize-hook #'org-modern-agenda) + +;; Option 2: Globally +(with-eval-after-load 'org (global-org-modern-mode)) +#+end_src + +Try the following more extensive setup in =emacs -Q= to reproduce the looks of the +screenshot above. + +#+begin_src emacs-lisp +;; Minimal UI +(package-initialize) +(menu-bar-mode -1) +(tool-bar-mode -1) +(scroll-bar-mode -1) +(modus-themes-load-operandi) + +;; Choose some fonts +;; (set-face-attribute 'default nil :family "Iosevka") +;; (set-face-attribute 'variable-pitch nil :family "Iosevka Aile") +;; (set-face-attribute 'org-modern-symbol nil :family "Iosevka") + +;; Add frame borders and window dividers +(modify-all-frames-parameters + '((right-divider-width . 40) + (internal-border-width . 40))) +(dolist (face '(window-divider + window-divider-first-pixel + window-divider-last-pixel)) + (face-spec-reset-face face) + (set-face-foreground face (face-attribute 'default :background))) +(set-face-background 'fringe (face-attribute 'default :background)) + +(setq + ;; Edit settings + org-auto-align-tags nil + org-tags-column 0 + org-catch-invisible-edits 'show-and-error + org-special-ctrl-a/e t + org-insert-heading-respect-content t + + ;; Org styling, hide markup etc. + org-hide-emphasis-markers t + org-pretty-entities t + + ;; Agenda styling + org-agenda-tags-column 0 + org-agenda-block-separator ?─ + org-agenda-time-grid + '((daily today require-timed) + (800 1000 1200 1400 1600 1800 2000) + " ┄┄┄┄┄ " "┄┄┄┄┄┄┄┄┄┄┄┄┄┄┄") + org-agenda-current-time-string + "◀── now ─────────────────────────────────────────────────") + +;; Ellipsis styling +(setq org-ellipsis "…") +(set-face-attribute 'org-ellipsis nil :inherit 'default :box nil) + +(global-org-modern-mode) +#+end_src + +* Alternatives + +The tag style of =org-modern= is inspired by Nicholas Rougier's beautiful +[[https://github.com/rougier/svg-tag-mode][svg-tag-mode]]. In contrast to =svg-tag-mode=, this package avoids images and uses +cheap and fast Emacs box text properties. By only styling the text via text +properties, the styled text, e.g., dates or tags stay editable and are easy to +interact with. + +The approach restricts our flexibility and may lead to font-dependent issues. We +do our best, but for example there is no way we can get round corners. Combining +=org-modern-mode= with =svg-tag-mode= is possible. You can use SVG tags and use the +table and block styling from =org-modern=. If you are interested in further +tweaks, Emacs comes with the builtin =prettify-symbols-mode= which can be used for +individual styling of custom keywords. + +Popular alternatives are the older =org-superstar= and =org-bullets= packages, which +have are more limited and mainly adjust headlines and lists. =org-superstar= +relies on character composition, while =org-modern= uses text properties, which +are considered more future-proof. Note that =org-modern= is a full replacement for +both =org-superstar= and =org-bullets=. You can easily disable styling of certain +elements, e.g., =org-modern-timestamp=, if you only want to use a subset of +=org-modern=. + +* Contributions + +Since this package is part of [[https://elpa.gnu.org/packages/org-modern.html][GNU ELPA]] contributions require a copyright +assignment to the FSF. diff --git a/homebase/public/.emacs.d/locext/org-modern/example.org b/homebase/public/.emacs.d/locext/org-modern/example.org new file mode 100644 index 00000000..177cde8a --- /dev/null +++ b/homebase/public/.emacs.d/locext/org-modern/example.org @@ -0,0 +1,153 @@ +#+title: Modern Org Example +#+author: Daniel Mendler +#+filetags: :example:org: + +This example Org file demonstrates the Org elements, +which are styled by =org-modern=. + +----- + +* Headlines +** Second level +*** Third level +**** Fourth level +***** Fifth level + +* Task Lists [1/3] + - [X] Write =org-modern= + - [-] Publish =org-modern= + - [ ] Fix all the bugs + +* List Bullets + - Dash + + Plus + * Asterisk + +* Timestamps +DEADLINE: <2022-03-01 Tue> +SCHEDULED: <2022-02-25 10:00> +DRANGE: [2022-03-01]--[2022-04-01] +DRANGE: <2022-03-01>--<2022-04-01> +TRANGE: [2022-03-01 Tue 10:42-11:00] +TIMESTAMP: [2022-02-21 Mon 13:00] +DREPEATED: <2022-02-26 Sat .+1d/2d +3d> +TREPEATED: <2022-02-26 Sat 10:00 .+1d/2d> + +* Blocks + +#+begin_src emacs-lisp + ;; Taken from the well-structured Emacs config by @oantolin. + ;; Take a look at https://github.com/oantolin/emacs-config! + (defun command-of-the-day () + "Show the documentation for a random command." + (interactive) + (let ((commands)) + (mapatoms (lambda (s) + (when (commandp s) (push s commands)))) + (describe-function + (nth (random (length commands)) commands)))) +#+end_src + +#+begin_src calc + taylor(sin(x),x=0,3) +#+end_src + +#+results: +: pi x / 180 - 2.85779606768e-8 pi^3 x^3 + +#+BEGIN_SRC C + printf("a|b\nc|d\n"); +#+END_SRC + +#+results: +| a | b | +| c | d | + + + + + + + +* Todo Labels and Tags +** DONE Write =org-modern= :emacs:foss:coding: +** TODO Publish =org-modern= +** WAIT Fix all the bugs + +* Priorities +** DONE [#A] Most important +** TODO [#B] Less important +** CANCEL [#C] Not that important +** DONE [100%] [#A] Everything combined :tag:test: + * [X] First + * [X] Second + * [X] Third + +* Tables + +| N | N^2 | N^3 | N^4 | sqrt(n) | sqrt[4](N) | +|---+----+----+----+---------+------------| +| 2 | 4 | 8 | 16 | 1.4142 | 1.1892 | +| 3 | 9 | 27 | 81 | 1.7321 | 1.3161 | + +|---+----+----+----+---------+------------| +| N | N^2 | N^3 | N^4 | sqrt(n) | sqrt[4](N) | +|---+----+----+----+---------+------------| +| 2 | 4 | 8 | 16 | 1.4142 | 1.1892 | +| 3 | 9 | 27 | 81 | 1.7321 | 1.3161 | +|---+----+----+----+---------+------------| + +#+begin_example +| a | b | c | +| a | b | c | +| a | b | c | +#+end_example + +* Special Links + +Test numeric footnotes[fn:1] and named footnotes[fn:foo]. + +<> + +<<>> + +[[This is an internal link]] + +radio link + +[fn:1] This is footnote 1 +[fn:foo] This is the foonote + +* Progress bars + +- quotient [1/13] +- quotient [2/13] +- quotient [3/13] +- quotient [4/13] +- quotient [5/13] +- quotient [6/13] +- quotient [7/13] +- quotient [8/13] +- quotient [9/13] +- quotient [10/13] +- quotient [11/13] +- quotient [12/13] +- quotient [13/13] + +- percent [0%] +- percent [1%] +- percent [2%] +- percent [5%] +- percent [10%] +- percent [20%] +- percent [30%] +- percent [40%] +- percent [50%] +- percent [60%] +- percent [70%] +- percent [80%] +- percent [90%] +- percent [100%] + +- overflow [110%] +- overflow [20/10] diff --git a/homebase/public/.emacs.d/locext/org-modern/org-modern.el b/homebase/public/.emacs.d/locext/org-modern/org-modern.el new file mode 100644 index 00000000..fc387f2e --- /dev/null +++ b/homebase/public/.emacs.d/locext/org-modern/org-modern.el @@ -0,0 +1,935 @@ +;;; org-modern.el --- Modern looks for Org -*- lexical-binding: t -*- + +;; Copyright (C) 2022-2024 Free Software Foundation, Inc. + +;; Author: Daniel Mendler +;; Maintainer: Daniel Mendler +;; Created: 2022 +;; Version: 1.2 +;; Package-Requires: ((emacs "27.1") (compat "29.1.4.4")) +;; Homepage: https://github.com/minad/org-modern +;; Keywords: outlines, hypermedia, text + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This package adds some styling to your Org buffer, which gives it a +;; modern look. Enable the styling by default with: +;; (add-hook 'org-mode-hook 'org-modern-mode) + +;;; Code: + +(require 'compat) +(require 'org) +(eval-when-compile + (require 'cl-lib) + (require 'subr-x)) + +(defgroup org-modern nil + "Modern looks for Org." + :link '(info-link :tag "Info Manual" "(org-modern)") + :link '(url-link :tag "Homepage" "https://github.com/minad/org-modern") + :link '(emacs-library-link :tag "Library Source" "org-modern.el") + :group 'org + :prefix "org-modern-") + +(defcustom org-modern-label-border 'auto + "Line width used for tag label borders. +If set to `auto' the border width is computed based on the `line-spacing'. +A value between 0.1 and 0.4 of `line-spacing' is recommended." + :type '(choice (const nil) (const auto) integer)) + +(defcustom org-modern-star 'fold + "Style heading stars. +Can be nil, fold or replace. See `org-modern-fold-stars' and +`org-modern-replace-stars' for the respective configurations." + :type '(choice (const :tag "No styling" nil) + (const :tag "Folding indicators" fold) + (const :tag "Replace" replace))) + +(defcustom org-modern-replace-stars "◉○◈◇✳" + "Replacement strings for headline stars for each level." + :type '(choice string (repeat string))) + +(defcustom org-modern-fold-stars + '(("▶" . "▼") ("▷" . "▽") ("⯈" . "⯆") ("▹" . "▿") ("▸" . "▾")) + "Folding indicators for headings. +Replace headings' stars with an indicator showing whether its +tree is folded or expanded." + :type '(repeat (cons (string :tag "Folded") + (string :tag "Expanded")))) + +(defcustom org-modern-hide-stars 'leading + "Changes the displays of the stars. +Can be leading, t, or a string/character replacement for each +leading star. Set to nil to disable." + :type '(choice + (string :tag "Replacement string for leading stars") + (character :tag "Replacement character for leading stars") + (const :tag "Do not hide stars" nil) + (const :tag "Hide all stars" t) + (const :tag "Hide leading stars" leading))) + +(defcustom org-modern-timestamp t + "Prettify time stamps, e.g. <2022-03-01>. +Set to nil to disable styling the time stamps. In order to use +custom timestamps, the format should be (DATE . TIME) where DATE +is the format for date, and TIME is the format for time. DATE +and TIME must be surrounded with space. For the syntax, refer to +`format-time-string'." + :type '(choice + (const :tag "Disable time stamp styling" nil) + (const :tag "Enable timestamp styling" t) + (const :tag "Use format YYYY-MM-DD HH:MM" (" %Y-%m-%d " . " %H:%M ")) + (cons :tag "Custom format" string string))) + +(defcustom org-modern-table t + "Prettify tables." + :type 'boolean) + +(defcustom org-modern-table-vertical 3 + "Width of vertical table lines in pixels. +Set to nil to hide the vertical lines." + :type '(choice (const nil) natnum)) + +(defcustom org-modern-table-horizontal 0.1 + "Prettify horizontal table lines." + :type '(choice (const nil) number)) + +(defcustom org-modern-priority t + "Prettify priorities. +If set to t, the priority will be prettified with the brackets +hidden. If set to an alist of characters and strings, the +associated string will be used as replacement for the given +priority. Example: + + (setq org-modern-priority + (quote ((?A . \"❗\") + (?B . \"⬆\") + (?C . \"⬇\"))))" + :type '(choice (boolean :tag "Prettify") + (alist :key-type (character :tag "Priority") + :value-type (string :tag "Replacement")))) + +(defcustom org-modern-list + '((?+ . "◦") + (?- . "–") + (?* . "•")) + "List of bullet replacement strings. +Set to nil to disable styling list bullets." + :type '(alist :key-type character :value-type string)) + +(defcustom org-modern-checkbox + '((?X . "☑") + (?- . #("□–" 0 2 (composition ((2))))) + (?\s . "□")) + "List of check box replacement strings. +Set to nil to disable styling checkboxes." + :type '(alist :key-type character :value-type string)) + +(defcustom org-modern-horizontal-rule t + "Prettify horizontal rulers. +The value can either be a boolean to enable/disable style or display +replacement expression, e.g., a string." + :type '(choice boolean sexp)) + +(defcustom org-modern-todo t + "Prettify todo keywords, see `org-todo-keywords'." + :type 'boolean) + +(defcustom org-modern-todo-faces nil + "Faces for todo keywords. +This is an alist, with todo keywords in the car and faces in the +cdr. Example: + + (setq org-modern-todo-faces + (quote ((\"TODO\" :background \"red\" :foreground \"yellow\"))))" + :type '(repeat + (cons (choice + (string :tag "Keyword") + (const :tag "Default" t)) + (sexp :tag "Face ")))) + +(defcustom org-modern-tag-faces nil + "Faces for tags keywords. +This is an alist, with tag the car and faces in the cdr. +Example: + + (setq org-modern-tag-faces + (quote ((\"emacs\" :background \"red\" :foreground \"yellow\"))))" + :type '(repeat + (cons (choice + (string :tag "Keyword") + (const :tag "Default" t)) + (sexp :tag "Face ")))) + +(defcustom org-modern-priority-faces nil + "Faces for priority tags. +This is an alist, with priority character in the car and faces in +the cdr. Example: + + (setq org-modern-priority-faces + (quote ((?A :background \"red\" + :foreground \"yellow\"))))" + :type '(repeat + (cons (choice + (character :tag "Priority") + (const :tag "Default" t)) + (sexp :tag "Face ")))) + +(defcustom org-modern-tag t + "Prettify tags in headlines, e.g., :tag1:tag2:." + :type 'boolean) + +(defcustom org-modern-block-name t + "Prettify blocks names, i.e. #+begin_NAME and #+end_NAME lines. +If set to a pair of two strings, e.g. (\"‣\" . \"‣\"), the strings are +used as replacements for the #+begin_ and #+end_ prefixes, respectively. +If set to an alist of block names and cons cells of strings, the associated +strings will be used as a replacements for the whole of #+begin_NAME and +#+end_NAME, respectively, and the association with t treated as the value for +all other blocks." + :type '(choice + (const :tag "Hide #+begin_ and #+end_ prefixes" t) + (cons (string :tag "#+begin_ replacement") + (string :tag "#+end_ replacement")) + (const :tag "Triangle bullets" ("‣" . "‣")) + (alist :key-type + (choice + (string :tag "Block name") + (const :tag "Default" t)) + :value-type + (choice + (list (string :tag "#+begin_NAME replacement") + (string :tag "#+end_NAME replacement")) + (const :tag "Hide #+begin_ and #+end_ prefixes" t))))) + +(defcustom org-modern-block-fringe 2 + "Add a border to the blocks in the fringe. +This variable can also be set to an integer between 0 and 16, +which specifies the offset of the block border from the edge of +the window." + :type '(choice boolean natnum)) + +(defcustom org-modern-keyword t + "Prettify keywords like #+title. +If set to t, the prefix #+ will be hidden. If set to a string, +e.g., \"‣\", the string is used as replacement for #+. If set to +an alist of keywords and strings, the associated string will be +used as replacement for \"#+keyword:\", with t the default key. +Example: + + (setq org-modern-keyword + (quote ((\"options\" . \"🔧\") + (t . t))))" + :type '(choice (boolean :tag "Hide prefix") + (string :tag "Replacement") + (const :tag "Triangle bullet" "‣") + (alist :key-type (choice (string :tag "Keyword") + (const :tag "Default" t)) + :value-type (choice (string :tag "Replacement") + (const :tag "Hide prefix" t))))) + +(defcustom org-modern-footnote (cons nil (cadr org-script-display)) + "Prettify footnotes. +The car corresponds to display specification for definitions, the cdr for +references." + :type '(choice (const nil) (cons sexp sexp))) + +(defcustom org-modern-internal-target '(" ↪ " t " ") + "Prettify internal link targets, e.g., <>." + :type '(choice (const nil) (list string boolean string))) + +(defcustom org-modern-radio-target '(" ⛯ " t " ") + "Prettify radio link targets, e.g., <<>>." + :type '(choice (const nil) (list string boolean string))) + +(defcustom org-modern-progress 12 + "Width in characters to draw progress bars. +Set to nil to disable bars." + :type '(choice (const :tag "Disable progress bar" nil) + (natnum :tag "Bar width"))) + +(defgroup org-modern-faces nil + "Faces used by `org-modern'." + :group 'org-modern + :group 'org-faces + :group 'faces) + +(defface org-modern-symbol nil + "Face used for stars, checkboxes and progress indicators. +You can specify a font `:family'. The font families `Iosevka', `Hack' and +`DejaVu Sans' give decent results.") + +(defface org-modern-label + `((t :height 0.8 :width condensed :weight regular :underline nil)) + "Parent face for labels. +The parameters of this face depend on typographical properties of +the font and should therefore be adjusted by the user depending +on their font, e.g., the :width or :height parameters. Themes +should not override this face, since themes usually don't control +the font.") + +(defface org-modern-block-name + '((t :height 0.8 :weight light)) + "Face used for block keywords.") + +(defface org-modern-progress-complete + '((((background light)) + :background "gray35" :foreground "white") + (t :background "gray75" :foreground "black")) + "Face used for completed section of progress bars (colors only).") + +(defface org-modern-progress-incomplete + '((((background light)) :background "gray90" :foreground "black") + (t :background "gray20" :foreground "white")) + "Face used for incomplete section of progress bars (colors only).") + +(defface org-modern-tag + '((default :inherit (secondary-selection org-modern-label)) + (((background light)) :foreground "black") + (t :foreground "white")) + "Face used for tag labels.") + +(defface org-modern-internal-target + '((t :inherit org-modern-done)) + "Face used for internal link targets.") + +(defface org-modern-radio-target + '((t :inherit org-modern-done)) + "Face used for radio link targets.") + +(defface org-modern-done + '((default :inherit org-modern-label) + (((background light)) :background "gray90" :foreground "black") + (t :background "gray20" :foreground "white")) + "Default face used for done labels.") + +(defface org-modern-todo + ;; `:inverse-video' to use todo foreground as label background + '((t :inherit (org-todo org-modern-label) + :weight semibold :inverse-video t)) + "Default face used for todo labels.") + +(defface org-modern-priority + ;; `:inverse-video' to use priority foreground as label background + '((t :inherit (org-priority org-modern-label) + :weight semibold :inverse-video t)) + "Default face used for priority labels.") + +(defface org-modern-date-active + '((default :inherit org-modern-label) + (((background light)) :background "gray90" :foreground "black") + (t :background "gray20" :foreground "white")) + "Face used for active date labels.") + +(defface org-modern-time-active + ;; Use `:distant-foreground' to ensure readability if `hl-line-mode' is used. + '((default :inherit org-modern-label :weight semibold) + (((background light)) + :background "gray35" :foreground "white" :distant-foreground "black") + (t :background "gray75" :foreground "black" :distant-foreground "white")) + "Face used for active time labels.") + +(defface org-modern-date-inactive + '((default :inherit org-modern-label) + (((background light)) + :background "gray90" :foreground "gray30") + (t :background "gray20" :foreground "gray70")) + "Face used for inactive date labels.") + +(defface org-modern-time-inactive + ;; Use `:distant-foreground' to ensure readability if `hl-line-mode' is used. + '((default :inherit org-modern-label :background "gray50") + (((background light)) :foreground "gray95" :distant-foreground "gray5") + (t :foreground "gray5" :distant-foreground "gray95")) + "Face used for inactive time labels.") + +(defface org-modern-horizontal-rule + '((default :inherit org-hide) + (((background light)) :strike-through "gray70") + (t :strike-through "gray30")) + "Face used for horizontal ruler.") + +(defvar-local org-modern--font-lock-keywords nil) +(defvar-local org-modern--folded-star-cache nil) +(defvar-local org-modern--expanded-star-cache nil) +(defvar-local org-modern--hide-stars-cache nil) +(defvar-local org-modern--checkbox-cache nil) +(defvar-local org-modern--table-sp-width 0) +(defconst org-modern--table-overline '(:overline t)) +(defconst org-modern--table-sp '((space :width (org-modern--table-sp-width)) + (space :width (org-modern--table-sp-width)))) + +(defun org-modern--checkbox () + "Prettify checkboxes according to `org-modern-checkbox'." + (let ((beg (match-beginning 3)) + (end (match-end 3))) + (put-text-property + beg end 'display + (cdr (assq (char-after (1+ beg)) org-modern--checkbox-cache))))) + +(defun org-modern--keyword () + "Prettify keywords according to `org-modern-keyword'." + (let ((beg (match-beginning 0)) + (end (match-end 0)) + (rep (and (listp org-modern-keyword) + (cdr (assoc (downcase (match-string-no-properties 2)) + org-modern-keyword))))) + (unless rep + (setq rep (cdr (assq t org-modern-keyword)) end (match-end 1))) + (pcase rep + ('t (put-text-property beg (match-end 1) 'invisible 'org-modern)) + ((pred stringp) + (put-text-property beg end 'display rep))))) + +(defun org-modern--priority () + "Prettify priorities according to `org-modern-priority'." + (let* ((beg (match-beginning 1)) + (end (match-end 1)) + (prio (char-before (1- end)))) + (if-let ((rep (and (consp org-modern-priority) + (cdr (assq prio org-modern-priority))))) + (put-text-property beg end 'display rep) + (put-text-property beg (1+ beg) 'display " ") + (put-text-property (1- end) end 'display " ") + (put-text-property + beg end 'face + (if-let ((face (or (cdr (assq prio org-modern-priority-faces)) + (cdr (assq t org-modern-priority-faces))))) + `(:inherit (,face org-modern-label)) + 'org-modern-priority))))) + +(defun org-modern--progress () + "Prettify progress as color-coded bar." + (let* ((beg (match-beginning 1)) + (end (match-end 1)) + (val (min 1.0 + (if (match-beginning 2) + (* 0.01 (string-to-number (match-string-no-properties 2))) + (let ((q (string-to-number (match-string-no-properties 4)))) + (if (= q 0) + 1.0 + (/ (* 1.0 (string-to-number (match-string-no-properties 3))) q)))))) + (w org-modern-progress) + (complete (floor (* w val))) + (w0 (- end beg 2)) + (w1 (/ (- w w0) 2)) + (bar (concat (make-string w1 ?\s) + (buffer-substring-no-properties (1+ beg) (1- end)) + (make-string (- w w1 w0) ?\s)))) + (put-text-property 0 complete 'face 'org-modern-progress-complete bar) + (put-text-property complete w 'face 'org-modern-progress-incomplete bar) + (put-text-property beg end 'face 'org-modern-label) + (put-text-property beg (1+ beg) 'display (substring bar 0 w1)) + (put-text-property (1- end) end 'display (substring bar (+ w1 w0) w)) + (dotimes (i w0) + (put-text-property (+ 1 beg i) (+ 2 beg i) + 'display (substring bar (+ w1 i) (+ w1 i 1)))))) + +(defun org-modern--tag () + "Prettify headline tags." + (save-excursion + (let* ((default-face (get-text-property (match-beginning 1) 'face)) + (colon-props `(display #(":" 0 1 (face org-hide)) face ,default-face)) + (beg (match-beginning 2)) + (end (match-end 2)) + colon-beg colon-end) + (goto-char beg) + (while (re-search-forward "::?" end 'noerror) + (let ((cbeg (match-beginning 0)) + (cend (match-end 0))) + (when colon-beg + (put-text-property colon-end (1+ colon-end) 'display + (format #(" %c" 1 3 (cursor t)) (char-after colon-end))) + (put-text-property (1- cbeg) cbeg 'display + (string (char-before cbeg) ?\s)) + (put-text-property + colon-end cbeg 'face + (if-let ((faces org-modern-tag-faces) + (face (or (cdr (assoc (buffer-substring-no-properties colon-end cbeg) faces)) + (cdr (assq t faces))))) + `(:inherit (,face org-modern-tag)) + 'org-modern-tag))) + (add-text-properties cbeg cend colon-props) + (setq colon-beg cbeg colon-end cend)))))) + +(defun org-modern--todo () + "Prettify headline todo keywords." + (let ((todo (match-string-no-properties 1)) + (beg (match-beginning 1)) + (end (match-end 1))) + (put-text-property beg (1+ beg) 'display + (format #(" %c" 1 3 (cursor t)) (char-after beg))) + (put-text-property (1- end) end 'display (string (char-before end) ?\s)) + (put-text-property + beg end 'face + (if-let ((face (or (cdr (assoc todo org-modern-todo-faces)) + (cdr (assq t org-modern-todo-faces))))) + `(:inherit (,face org-modern-label)) + (if (member todo org-done-keywords) + 'org-modern-done + 'org-modern-todo))))) + +(defun org-modern--timestamp () + "Prettify timestamps." + (let* ((beg (match-beginning 0)) + (end (match-end 0)) + (tbeg (match-beginning 2)) + (tend (match-end 2)) + (active (eq (char-after beg) ?<)) + (date-face (if active + 'org-modern-date-active + 'org-modern-date-inactive)) + (time-face (if active + 'org-modern-time-active + 'org-modern-time-inactive))) + (remove-list-of-text-properties beg end '(display)) + (if (consp org-modern-timestamp) + (let* ((time (save-match-data + (encode-time + (org-fix-decoded-time + (org-parse-time-string + (buffer-substring beg end)))))) + (fmt org-modern-timestamp) + (date-str (format-time-string (car fmt) time)) + (time-str (format-time-string (cdr fmt) time))) + ;; year-month-day + (add-text-properties beg (if (eq tbeg tend) end tbeg) + `(face ,date-face display ,date-str)) + ;; hour:minute + (unless (eq tbeg tend) + (add-text-properties tbeg end + `(face ,time-face display ,time-str)))) + (put-text-property beg (1+ beg) 'display " ") + (put-text-property (1- end) end 'display " ") + ;; year-month-day + (put-text-property beg (if (eq tbeg tend) end tbeg) 'face date-face) + ;; hour:minute + (unless (eq tbeg tend) + (put-text-property (1- tbeg) tbeg 'display + (string (char-before tbeg) ?\s)) + (put-text-property tbeg end 'face time-face))))) + +(defun org-modern--star () + "Prettify headline stars." + (let* ((beg (match-beginning 1)) + (end (match-end 1)) + (level (- end beg))) + (when (and org-modern--hide-stars-cache (not (eq beg end))) + (cl-loop for i from beg below end do + (put-text-property i (1+ i) 'display + (nth (logand i 1) + org-modern--hide-stars-cache)))) + (when org-modern-star + (when (and (eq org-modern-hide-stars 'leading) org-hide-leading-stars) + (put-text-property beg (1+ end) 'face (get-text-property end 'face))) + (put-text-property + (if (eq org-modern-hide-stars 'leading) beg end) + (1+ end) 'display + (let ((cache (if (and org-modern--folded-star-cache + (org-invisible-p (pos-eol))) + org-modern--folded-star-cache + org-modern--expanded-star-cache))) + (aref cache (min (1- (length cache)) level))))))) + +(defun org-modern--cycle (state) + "Flush font-lock for buffer or line at point for `org-cycle-hook'. +When STATE is `overview', `contents', or `all', flush for the +whole buffer; otherwise, for the line at point." + (pcase state + ((or 'overview 'contents 'all) (font-lock-flush)) + (_ (font-lock-flush (pos-bol) (pos-eol))))) + +(defun org-modern--table () + "Prettify vertical table lines." + (save-excursion + (let* ((beg (match-beginning 0)) + (end (match-end 0)) + (tbeg (match-beginning 1)) + (tend (match-end 1)) + (inner (progn + (goto-char beg) + (forward-line) + (re-search-forward "^[ \t]*|" (line-end-position) t))) + (separator (progn + (goto-char beg) + (re-search-forward "^[ \t]*|-" end 'noerror)))) + (goto-char beg) + (while (re-search-forward + "-+\\(?1:+\\)-\\|\\(?:^\\|[- ]\\)\\(?1:|\\)\\(?:$\\|[- ]\\)" + end 'noerror) + (let ((a (match-beginning 1)) + (b (match-end 1))) + (cond + ((and org-modern-table-vertical (or (not separator) inner)) + (add-text-properties a b + `(display (space :width (,org-modern-table-vertical)) + face (:inherit org-table :inverse-video t)))) + ((and org-modern-table-horizontal separator) + (put-text-property a b 'display `(space :width (,org-modern-table-vertical)))) + (t (put-text-property a b 'face 'org-hide))))) + (goto-char beg) + (when separator + (when (numberp org-modern-table-horizontal) + (add-face-text-property tbeg tend org-modern--table-overline 'append) + (add-face-text-property beg (1+ end) `(:height ,org-modern-table-horizontal) 'append)) + (while (re-search-forward "[^|+]+" tend 'noerror) + (let ((a (match-beginning 0)) + (b (match-end 0))) + (cl-loop for i from a below b do + (put-text-property i (1+ i) 'display + (nth (logand i 1) org-modern--table-sp))))))))) + +(defun org-modern--block-name () + "Prettify block according to `org-modern-block-name'." + (let* ((beg-ind (match-beginning 1)) + (beg-rep (match-beginning 2)) + (end-rep (match-end 3)) + (beg-name (match-beginning 3)) + (end-name (match-end 3)) + (names (and (listp org-modern-block-name) org-modern-block-name)) + (rep (cdr (assoc (downcase (match-string-no-properties 3)) names))) + (fringe (and org-modern-block-fringe (not (bound-and-true-p org-indent-mode))))) + (unless rep + (setq rep (cdr (assq t names)) end-rep beg-name)) + (when (consp rep) + (setq rep (if (= 8 (- beg-name beg-rep)) (car rep) (cadr rep)))) + (pcase rep + ('t + (add-face-text-property beg-name end-name 'org-modern-block-name) + (put-text-property (if fringe beg-ind beg-rep) beg-name 'invisible 'org-modern)) + ((pred stringp) + (add-face-text-property beg-name end-name 'org-modern-block-name) + (put-text-property beg-rep end-rep 'display rep) + (when fringe + (put-text-property beg-ind beg-rep 'invisible 'org-modern)))))) + +(defun org-modern--block-fringe () + "Prettify blocks with fringe bitmaps." + (save-excursion + (goto-char (match-beginning 0)) + (add-text-properties + (point) (min (line-end-position) (point-max)) + '(wrap-prefix + #(" " 0 1 (display (left-fringe org-modern--block-begin org-block-begin-line))) + line-prefix + #(" " 0 1 (display (left-fringe org-modern--block-begin org-block-begin-line))))) + (forward-line) + (while + (cond + ((eobp) nil) + ((save-excursion + (let ((case-fold-search t)) + (re-search-forward + "^[ \t]*#\\+end_" (line-end-position) 'noerror))) + (add-text-properties + (point) (min (line-end-position) (point-max)) + '(wrap-prefix + #(" " 0 1 (display (left-fringe org-modern--block-end org-block-begin-line))) + line-prefix + #(" " 0 1 (display (left-fringe org-modern--block-end org-block-begin-line))))) + nil) + (t + (add-text-properties + (point) (min (1+ (line-end-position)) (point-max)) + '(wrap-prefix + #(" " 0 1 (display (left-fringe org-modern--block-inner org-block-begin-line))) + line-prefix + #(" " 0 1 (display (left-fringe org-modern--block-inner org-block-begin-line))))) + (forward-line) + t))))) + +(defun org-modern--pre-redisplay (_) + "Compute font parameters before redisplay." + (when-let ((box (and org-modern-label-border + (face-attribute 'org-modern-label :box nil t)))) + (unless (equal (and (listp box) (plist-get box :color)) + (face-attribute 'default :background nil t)) + (org-modern--update-label-face))) + (setf org-modern--table-sp-width (default-font-width) + (cadr org-modern--table-overline) (face-attribute 'org-table :foreground nil t))) + +(defun org-modern--update-label-face () + "Update border of the `org-modern-label' face." + (set-face-attribute + 'org-modern-label nil + :box + (when org-modern-label-border + (let ((border (if (eq org-modern-label-border 'auto) + (max 2 (cond + ((integerp line-spacing) + line-spacing) + ((floatp line-spacing) + (ceiling (* line-spacing (frame-char-height)))) + (t (/ (frame-char-height) 10)))) + org-modern-label-border))) + (list :color (face-attribute 'default :background nil t) + :line-width + ;; Emacs 28 supports different line horizontal and vertical line widths + (if (eval-when-compile (>= emacs-major-version 28)) + (cons -1 (- border)) + (- border))))))) + +(defun org-modern--update-fringe-bitmaps () + "Update fringe bitmaps." + (when (and org-modern-block-fringe + (fboundp 'fringe-bitmap-p) + (not (fringe-bitmap-p 'org-modern--block-inner))) + (let* ((g (ceiling (frame-char-height) 1.8)) + (h (- (default-line-height) g)) + (v (expt 2 (- 15 (if (booleanp org-modern-block-fringe) 0 + org-modern-block-fringe)))) + (w (+ v v -1))) + (define-fringe-bitmap 'org-modern--block-inner + (vector v) nil 16 '(top t)) + (define-fringe-bitmap 'org-modern--block-begin + (vconcat (make-vector g 0) (vector w) (make-vector (- 127 g) v)) nil 16 'top) + (define-fringe-bitmap 'org-modern--block-end + (vconcat (make-vector (- 127 h) v) (vector w) (make-vector h 0)) nil 16 'bottom)))) + +(defun org-modern--symbol (str) + "Add `org-modern-symbol' face to STR." + (setq str (if (stringp str) (copy-sequence str) (char-to-string str))) + (add-face-text-property 0 (length str) 'org-modern-symbol 'append str) + str) + +(defun org-modern--make-font-lock-keywords () + "Compute font-lock keywords." + (append + (when-let ((bullet (alist-get ?+ org-modern-list))) + `(("^[ \t]*\\(+\\)[ \t]" 1 '(face nil display ,bullet)))) + (when-let ((bullet (alist-get ?- org-modern-list))) + `(("^[ \t]*\\(-\\)[ \t]" 1 '(face nil display ,bullet)))) + (when-let ((bullet (alist-get ?* org-modern-list))) + `(("^[ \t]+\\(*\\)[ \t]" 1 '(face nil display ,bullet)))) + (when org-modern-priority + `(("^\\*+.*? \\(\\(\\[\\)#.\\(\\]\\)\\) " + (1 (org-modern--priority))))) + (when org-modern-todo + `((,(format "^\\*+ +%s\\(?: \\|$\\)" (regexp-opt org-todo-keywords-1 t)) + (0 (org-modern--todo))))) + (when org-modern-checkbox + `((,org-list-full-item-re + (3 (org-modern--checkbox) nil t)))) + (when (or org-modern-star org-modern-hide-stars) + `(("^\\(\\**\\)\\* " + (0 ,(if (eq org-modern-hide-stars t) + ''(face nil invisible org-modern) + '(org-modern--star)))))) + (when org-modern-horizontal-rule + `(("^[ \t]*-\\{5,\\}$" 0 + '(face org-modern-horizontal-rule display + ,(if (eq org-modern-horizontal-rule t) + '(space :width text) + org-modern-horizontal-rule))))) + (when org-modern-table + '(("^[ \t]*\\(|.*|\\)[ \t]*$" (0 (org-modern--table))))) + (when org-modern-footnote + `(("^\\(\\[fn:\\)[[:word:]-_]+\\]" ;; Definition + ,@(if-let ((x (car org-modern-footnote))) + `((0 '(face nil display ,x)) + (1 '(face nil display ,(propertize "[" 'display x)))) + '((1 '(face nil display "["))))) + ("[^\n]\\(\\(\\[fn:\\)[[:word:]-_]+\\]\\)" ;; Reference + ,@(if-let ((x (cdr org-modern-footnote))) + `((1 '(face nil display ,x)) + (2 '(face nil display ,(propertize "[" 'display x)))) + '((2 '(face nil display "["))))))) + (let ((target "\\([^<>\n\r\t ][^<>\n\r]*?[^<>\n\r\t @$]\\|[^<>\n\r\t @$]\\)")) + (append + (when org-modern-internal-target + `((,(format "\\(<<\\)%s\\(>>\\)" target) + (0 '(face org-modern-internal-target) t) + (1 '(face nil display ,(org-modern--symbol (car org-modern-internal-target)))) + (3 '(face nil display ,(org-modern--symbol (caddr org-modern-internal-target)))) + ,@(unless (cadr org-modern-internal-target) + '((2 '(face nil invisible org-modern))))))) + (when org-modern-radio-target + `((,(format "\\(<<<\\)%s\\(>>>\\)" target) + (0 '(face org-modern-radio-target) t) + (1 '(face nil display ,(org-modern--symbol (car org-modern-radio-target)))) + (3 '(face nil display ,(org-modern--symbol (caddr org-modern-radio-target)))) + ,@(unless (cadr org-modern-radio-target) + '((2 '(face nil invisible org-modern))))))))) + (when org-modern-timestamp + '(("\\(?:<\\|\\[\\)\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\(?: [[:word:]]+\\.?\\)?\\(?: [.+-]+[0-9ymwdh/]+\\)*\\)\\(\\(?: [0-9:-]+\\)?\\(?: [.+-]+[0-9ymwdh/]+\\)*\\)\\(?:>\\|\\]\\)" + (0 (org-modern--timestamp))) + ("<[^>]+>\\(-\\)\\(-\\)<[^>]+>\\|\\[[^]]+\\]\\(?1:-\\)\\(?2:-\\)\\[[^]]+\\]" + (1 '(face org-modern-label display #(" " 1 2 (face (:strike-through t) cursor t))) t) + (2 '(face org-modern-label display #(" " 0 1 (face (:strike-through t)))) t)))) + (when (integerp org-modern-progress) + `((" \\(\\[\\(?:\\([0-9]+\\)%\\|\\([0-9]+\\)/\\([0-9]+\\)\\)]\\)" + (0 (org-modern--progress))))) + (when org-modern-tag + `((,(concat "^\\*+.*?\\( \\)\\(:\\(?:" org-tag-re ":\\)+\\)[ \t]*$") + (0 (org-modern--tag))))) + ;; Ensure that blocks are properly fontified, source blocks etc. This + ;; fontification rule must come late such that org-modern does not interfere + ;; with source fontification. + '((org-fontify-meta-lines-and-blocks)) + (when org-modern-tag + `((,(concat "^[ \t]*#\\+\\(?:filetags\\|FILETAGS\\):\\( +\\)\\(:\\(?:" + org-tag-re ":\\)+\\)[ \t]*$") + (0 (org-modern--tag))))) + (when org-modern-keyword + `(("^[ \t]*\\(#\\+\\)\\([^: \t\n]+\\):" + ,@(pcase org-modern-keyword + ('t '(1 '(face nil invisible org-modern))) + ((pred stringp) `(1 '(face nil display ,org-modern-keyword))) + (_ '(0 (org-modern--keyword))))))) + ;; Do not add source block fringe markers if org-indent-mode is + ;; enabled. org-indent-mode uses line prefixes for indentation. + ;; Therefore we cannot have both. + (when (and org-modern-block-fringe (not (bound-and-true-p org-indent-mode))) + '(("^[ \t]*#\\+\\(?:begin\\|BEGIN\\)_\\S-" + (0 (org-modern--block-fringe))))) + (when org-modern-block-name + (let* ((indent (and org-modern-block-fringe + (not (bound-and-true-p org-indent-mode)) + '((1 '(face nil invisible org-modern))))) + (name '(3 'org-modern-block-name append)) + (hide `(,@indent (2 '(face nil invisible org-modern)) ,name)) + (specs + (pcase org-modern-block-name + ('t ;; Hide + (cons hide hide)) + (`((,_k . ,_v) . ,_rest) ;; Dynamic replacement + '(((0 (org-modern--block-name))) . ((0 (org-modern--block-name))))) + (`(,beg . ,end) ;; Static replacement + `((,@indent (2 '(face nil display ,beg)) ,name) . + (,@indent (2 '(face nil display ,end)) ,name)))))) + `(("^\\([ \t]*\\)\\(#\\+\\(?:begin\\|BEGIN\\)_\\)\\(\\S-+\\).*" + ,@(car specs)) + ("^\\([ \t]*\\)\\(#\\+\\(?:end\\|END\\)_\\)\\(\\S-+\\).*" + ,@(cdr specs))))))) + +;;;###autoload +(define-minor-mode org-modern-mode + "Modern looks for Org." + :global nil + :group 'org-modern + (unless (derived-mode-p 'org-mode) + (error "`org-modern-mode' should be enabled only in `org-mode'")) + (cond + (org-modern-mode + (add-to-invisibility-spec 'org-modern) + (setq + org-modern--folded-star-cache + (and (eq org-modern-star 'fold) + (vconcat (mapcar #'org-modern--symbol (mapcar #'car org-modern-fold-stars)))) + org-modern--expanded-star-cache + (and org-modern-star + (vconcat (mapcar #'org-modern--symbol (if (eq org-modern-star 'fold) + (mapcar #'cdr org-modern-fold-stars) + org-modern-replace-stars)))) + org-modern--hide-stars-cache + (and (char-or-string-p org-modern-hide-stars) + (list (org-modern--symbol org-modern-hide-stars) + (org-modern--symbol org-modern-hide-stars))) + org-modern--checkbox-cache + (mapcar (pcase-lambda (`(,k . ,v)) (cons k (org-modern--symbol v))) + org-modern-checkbox) + org-modern--font-lock-keywords + (append (remove '(org-fontify-meta-lines-and-blocks) org-font-lock-keywords) + (org-modern--make-font-lock-keywords))) + (font-lock-remove-keywords nil org-font-lock-keywords) + (font-lock-add-keywords nil org-modern--font-lock-keywords) + (setq-local font-lock-unfontify-region-function #'org-modern--unfontify) + (add-hook 'pre-redisplay-functions #'org-modern--pre-redisplay nil 'local) + (add-hook 'org-after-promote-entry-hook #'org-modern--unfontify-line nil 'local) + (add-hook 'org-after-demote-entry-hook #'org-modern--unfontify-line nil 'local) + (when (eq org-modern-star 'fold) + (add-hook 'org-cycle-hook #'org-modern--cycle nil 'local)) + (org-modern--update-label-face) + (org-modern--update-fringe-bitmaps)) + (t + (remove-from-invisibility-spec 'org-modern) + (font-lock-remove-keywords nil org-modern--font-lock-keywords) + (font-lock-add-keywords nil org-font-lock-keywords) + (setq-local font-lock-unfontify-region-function #'org-unfontify-region) + (remove-hook 'pre-redisplay-functions #'org-modern--pre-redisplay 'local) + (remove-hook 'org-after-promote-entry-hook #'org-modern--unfontify-line 'local) + (remove-hook 'org-after-demote-entry-hook #'org-modern--unfontify-line 'local) + (when (eq org-modern-star 'fold) + (remove-hook 'org-cycle-hook #'org-modern--cycle 'local)))) + (without-restriction + (with-silent-modifications + (org-modern--unfontify (point-min) (point-max))) + (font-lock-flush))) + +(defun org-modern--unfontify-line () + "Unfontify prettified elements on current line." + (org-modern--unfontify (pos-bol) (pos-eol))) + +(defun org-modern--unfontify (beg end &optional _loud) + "Unfontify prettified elements between BEG and END." + (let ((font-lock-extra-managed-props + (append + ;; Only remove line/wrap-prefix if block fringes are used + (if (and org-modern-block-fringe (not (bound-and-true-p org-indent-mode))) + '(wrap-prefix line-prefix display invisible) + '(display invisible)) + font-lock-extra-managed-props))) + (org-unfontify-region beg end))) + +;;;###autoload +(defun org-modern-agenda () + "Finalize Org agenda highlighting." + (remove-from-invisibility-spec 'org-modern) + (add-to-invisibility-spec 'org-modern) ;; Not idempotent?! + (add-hook 'pre-redisplay-functions #'org-modern--pre-redisplay nil 'local) + (save-excursion + (save-match-data + (let (case-fold-search) + (when org-modern-todo + (goto-char (point-min)) + (let ((re (format " %s " + (regexp-opt + (append org-todo-keywords-for-agenda + org-done-keywords-for-agenda) t))) + (org-done-keywords org-done-keywords-for-agenda)) + (while (re-search-forward re nil 'noerror) + (org-modern--todo)))) + (when org-modern-tag + (goto-char (point-min)) + (let ((re (concat "\\( \\)\\(:\\(?:" org-tag-re "::?\\)+\\)[ \t]*$"))) + (while (re-search-forward re nil 'noerror) + (org-modern--tag)))) + (when org-modern-priority + (goto-char (point-min)) + (while (re-search-forward "\\(\\[#.\\]\\)" nil 'noerror) + ;; For some reason the org-agenda-fontify-priorities adds overlays?! + (when-let ((ov (overlays-at (match-beginning 0)))) + (overlay-put (car ov) 'face nil)) + (org-modern--priority))))))) + +;;;###autoload +(define-globalized-minor-mode global-org-modern-mode + org-modern-mode org-modern--on + :group 'org-modern + (if global-org-modern-mode + (add-hook 'org-agenda-finalize-hook #'org-modern-agenda) + (remove-hook 'org-agenda-finalize-hook #'org-modern-agenda))) + +(defun org-modern--on () + "Enable `org-modern' in every Org buffer." + (when (derived-mode-p #'org-mode) + (org-modern-mode))) + +(provide 'org-modern) +;;; org-modern.el ends here diff --git a/homebase/public/.emacs.d/locext/valign/.elpaignore b/homebase/public/.emacs.d/locext/valign/.elpaignore new file mode 100644 index 00000000..52024609 --- /dev/null +++ b/homebase/public/.emacs.d/locext/valign/.elpaignore @@ -0,0 +1,3 @@ +*.png +Makefile +test.org \ No newline at end of file diff --git a/homebase/public/.emacs.d/locext/valign/Makefile b/homebase/public/.emacs.d/locext/valign/Makefile new file mode 100644 index 00000000..0acef7f2 --- /dev/null +++ b/homebase/public/.emacs.d/locext/valign/Makefile @@ -0,0 +1,15 @@ +test: + emacs -Q -l ./valign.el --eval \ +'(progn (find-file "./test.org") (valign-mode) (variable-pitch-mode))' + +bar: + emacs -Q -l ./valign.el --eval \ +'(progn (find-file "./test.org") (setq valign-fancy-bar t) (valign-mode) (variable-pitch-mode))' + +indent: + emacs -Q -l ./valign.el --eval \ +'(progn (setq org-startup-indented t) (find-file "./test.org") (valign-mode) (variable-pitch-mode) (goto-char (point-max)))' + +mono: + emacs -Q -l ./valign.el --eval \ +'(progn (find-file "./test.org") (valign-mode))' diff --git a/homebase/public/.emacs.d/locext/valign/README-CN.org b/homebase/public/.emacs.d/locext/valign/README-CN.org new file mode 100644 index 00000000..cc4d52c1 --- /dev/null +++ b/homebase/public/.emacs.d/locext/valign/README-CN.org @@ -0,0 +1,49 @@ +#+TITLE: Valign.el + +这个包能对齐 Org Mode、Markdown和table.el 的表格。它能对齐包含不等宽字体、中日韩字符、图片的表格。valign 不会影响 Org Mode（或 Markdown mode）基于等宽字符的对齐。 + +想要用 valign.el 的话，先加载 valign.el，然后把 ~valign-mode~ 加到 ~org-mode-hook~ 或 ~markdown-mode-hook~ 里即可。 +#+begin_src emacs-lisp +(add-hook 'org-mode-hook #'valign-mode) +#+end_src + +[[./default.png]] + +[[./table.el.png]] + +*已知问题:* + +- Markdown Mode 里的隐藏链接依然会占用整个链接的宽度，因为隐藏链接用了 valign 还不支持的 character composition。 +- 渲染大型表格（≥100行）速度较慢。 + +*注意:* + +如果想要 valign 对齐 table.el 表格，表格里每个单元格的左侧不能有空格，右侧至少要有一个空格。可以用 [[https://github.com/casouri/ftable][ftable.el]] 自动布局表格成这样。 + +* 安装 + +键入如下内容，从 GNU ELPA 获取 valign.el: +#+begin_src +M-x package-install RET valign RET +#+end_src + +* 自定义 + +设置 ~valign-fancy-bar~ 为 ~non-nil~ 的效果如下: + +[[./fancy-bar.png]] + +仅影响 Org Mode和Markdown 的表格。 + +默认情况下，valign 不会在普通编辑命令之后对齐表格，例如 ~self-insert-command~ 和 ~backward-kill-word~​。如果你不想在某些命令后对齐表格，可以把命令加入 ~valign-not-align-after-list~ 中。 + +因为 valign 性能一般，所以我们不会对齐大于四千个字的表格。你可以修改 ~valign-max-table-size~ 改变这个限制。valign 会把 ~valign-table-fallback~ face 置于这些没有对齐的表格上。 + +其他自定义选项： +- ~valign-signal-parse-error~: 设为 non-nil，valign 遇到语法分析错误（parse error）时会报错提示。 +- ~valign-lighter~: mode-line 里显示的标识。 +- ~valign-box-charset-alist~: 用来定义 table.el 表格，比如 Unicode/ASCII 表格. + +* 如果函数 advice 让你浑身发痒 + +~valign-mode~ 会加一些 advice，即使你关闭了 ~valign-mode~​，这些 advice 也不会消失 ，因为函数advice是全局起效，而 ~valign-mode~ 是局部起效。 如果你想删掉这些 advice，请用 ~valign-remove-advice~ 。 这时候如果有 buffer 里还开着 ~valign-mode~​，这些 buffer 里的 valign 将无法正常工作。 diff --git a/homebase/public/.emacs.d/locext/valign/README.org b/homebase/public/.emacs.d/locext/valign/README.org new file mode 100644 index 00000000..6585e3a8 --- /dev/null +++ b/homebase/public/.emacs.d/locext/valign/README.org @@ -0,0 +1,48 @@ +#+TITLE: Valign.el + +[[file:README-CN.org][中文 README]] + +This package provides visual alignment for Org Mode, Markdown and table.el tables on GUI Emacs. It can properly align tables containing variable-pitch font, CJK characters and images. Meanwhile, the text-based alignment generated by Org mode (or Markdown mode) is left untouched. + +To use this package, load it and add ~valign-mode~ to ~org-mode-hook~ or ~markdown-mode-hook~: +#+begin_src emacs-lisp +(add-hook 'org-mode-hook #'valign-mode) +#+end_src + +[[./default.png]] + +[[./table.el.png]] + +*Known problems:* +- Hidden links in markdown still occupy the full length of the link, because it uses character composition which we don’t support now. +- Rendering large tables (≥100 lines) is laggy. + +*Note:* + +For table.el tables to work with valign, each cell has to have at least one space on the right and no space on the left. You can use [[https://github.com/casouri/ftable][ftable.el]] to auto-layout the table for you. + +* Install + +You can obtain valign.el from GNU ELPA by typing: +#+begin_src +M-x package-install RET valign RET +#+end_src + +* Customization +Set ~valign-fancy-bar~ to ~non-nil~: + +[[./fancy-bar.png]] + +This only affects Org Mode and Markdown tables. + +By default, valign doesn’t re-align the table after normal edit commands like ~self-insert-command~ and ~backward-kill-word~. If you want valign to not re-align the table after a certain command, add that command to ~valign-not-align-after-list~. + +Because valign isn’t particularly efficient, it doesn’t align tables larger than 4000 characters in size. If you want to change that behavior, customize ~valign-max-table-size~. Valign puts ~valign-table-fallback~ face on those large tables. + +Other (less interesting) customization: +- ~valign-signal-parse-error~: Set to non-nil to be informed of parse errors. +- ~valign-lighter~: Lighter in mode-line. +- ~valign-box-charset-alist~: Used for defining table.el tables, e.g., Unicode/ASCII tables. + +* If function advice makes you itch +~valign-mode~ adds advice and doesn’t remove them even if you close ~valign-mode~ because function advice is global and ~valign-mode~ is local. If you want to remove the advice, use ~valign-remove-advice~. If you run this while some buffer still has ~valign-mode~ on, they break. diff --git a/homebase/public/.emacs.d/locext/valign/default.png b/homebase/public/.emacs.d/locext/valign/default.png new file mode 100644 index 00000000..460f0e77 Binary files /dev/null and b/homebase/public/.emacs.d/locext/valign/default.png differ diff --git a/homebase/public/.emacs.d/locext/valign/fancy-bar.png b/homebase/public/.emacs.d/locext/valign/fancy-bar.png new file mode 100644 index 00000000..64d090db Binary files /dev/null and b/homebase/public/.emacs.d/locext/valign/fancy-bar.png differ diff --git a/homebase/public/.emacs.d/locext/valign/single-column.png b/homebase/public/.emacs.d/locext/valign/single-column.png new file mode 100644 index 00000000..0c8cbbda Binary files /dev/null and b/homebase/public/.emacs.d/locext/valign/single-column.png differ diff --git a/homebase/public/.emacs.d/locext/valign/table.el.png b/homebase/public/.emacs.d/locext/valign/table.el.png new file mode 100644 index 00000000..31730ea1 Binary files /dev/null and b/homebase/public/.emacs.d/locext/valign/table.el.png differ diff --git a/homebase/public/.emacs.d/locext/valign/test.org b/homebase/public/.emacs.d/locext/valign/test.org new file mode 100644 index 00000000..a76e665d --- /dev/null +++ b/homebase/public/.emacs.d/locext/valign/test.org @@ -0,0 +1,262 @@ + | $A_4$ | $n_c$ | c | $1$ | $1'$ | $1''$ | 3 | + |-------+-------+----------+-----+--------------+--------------+----| + | 1 | 1 | I | 1 | 1 | 1 | 3 | + | $Z_2$ | 3 | (12)(34) | 1 | 1 | 1 | -1 | + | $Z_3$ | 4 | (123) | 1 | $\omega$ | $\omega^{*}$ | 0 | + | $Z_3$ | 4 | (132) | 1 | $\omega^{*}$ | $\omega$ | 0 | + +| 111111111111111111111111111111111111111111111111111111111111 | +| 我我我我我我我我我我我我我我我我我我我我我我我我我我我我 | +| 我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我我 | +| | +| | + +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | + ++ hi ++ good ++ gosh + +- wow +- list + + +#+begin_example +|---+------------------------------| |---+--------| +| | | | | <6> | +| 1 | one | | 1 | one | +| 2 | two | ----\ | 2 | two | +| 3 | This is a long chunk of text | ----/ | 3 | This=> | +| 4 | four | | 4 | four | +|---+------------------------------| |---+--------| +#+end_example + +Unicode table: +┌─────────────────────────┬─────────────────────────────────────────┐ +│Options │Description │ +├─────────────────────────┼─────────────────────────────────────────┤ +│~zeft-directory~ │Directory in where notes are stored. │ +│ │Must be a full path. │ +├─────────────────────────┼─────────────────────────────────────────┤ +│~zeft-find-file-hook~ │Hook run when Zeft opens a file. │ +├─────────────────────────┼─────────────────────────────────────────┤ +│~zeft-selection~ │Face for the current selected search │ +│ │result. │ +├─────────────────────────┼─────────────────────────────────────────┤ +│~zeft-inline-highlight~ │Face for inline highlighting in Zeft │ +│ │buffer. │ +├─────────────────────────┼─────────────────────────────────────────┤ +│~zeft-preview-highlight~ │Face for highlighting in the preview │ +│ │buffer. │ +└─────────────────────────┴─────────────────────────────────────────┘ + + +* Foo +** Bar +*** Baz +| foo | bar | baz | +| thing | (foo bar baz) | bla | +| foo | bar | asdfasdf | +| <0> | | | + +* H + +| Header | +|-----------| +| Body | +| Text | +| Cell | +| 3 | +| 4 | +| 5 | +| 888888888 | +| 4 | + ++--+--------------------+-----------------+-----------------------+ +| |Cardiorespiratory |Strength |Flexibility Training | +| |Endurance |Training | | ++--+--------------------+-----------------+-----------------------+ +|F |Most days of the |2–3 days/week |2–3 days/week; ideally | +| |week |non-consecutive |5–7 days/week | ++--+--------------------+-----------------+-----------------------+ +|I |55–85% of max heart |Should fatigue |Feel slight tension | +| |rate |the muscle |during the stretch, | +| | | |but not pain | ++--+--------------------+-----------------+-----------------------+ +|T |30–60 minutes or 20 |8–12 reps for 1 |2–4 reps holding each | +| |minutes of vigorous |or more sets of |stretch for 10–30 | +| |activity |8–10 exercises |seconds | ++--+--------------------+-----------------+-----------------------+ +|T |Continuous activity |All major muscle |All major joints | +| |that uses large |groups | | +| |muscle groups | | | ++--+--------------------+-----------------+-----------------------+ + ++-----+-------------+-----+------+ +|你好 |中文长点更长 | | | ++-----+-------------+-----+------+ +|good |hi |表格 |table | ++-----+-------------+-----+------+ +| | | | | ++-----+-------------+-----+------+ +| | | | | ++-----+-------------+-----+------+ + ++--------------------+--------------------+ +|这是一行中文 |这还是一行中文 | ++--------------------+--------------------+ +|HHH |III | ++--------------------+--------------------+ + +#+latex: : | Table | Header | Header | +|------------+---------------------------------+----| +| 汉字中文…… | ddddddddddddddddddddddddddddddd | CC | +| Serif…… | Variable width | | +#+latex: : Table + +| Peace | August | Love | +|----------------+--------------+------| +| ssh tunnel | woome | 23f | +| 对齐等宽 | 日本語もいい | 89 | +| 中文汉字 | 感动 | 133 | +| rgfe | 图片 | 12 | +| variable-pitch | x | 13 | +| thirteen | Ω | 88 | +| great | www | 98 | + +**** header +#+name: hey +| a | b | | +|------+--------------+----| +| 你好 | +我不好+ | | +| hi | good morning | | +| ~hi~ | good | hi | + +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | + + +* header + +| | | hi | +| 测试一下 | | | +| [[www.veemo.com][link]] | | | + +|----------------------------------+---+---| +| Data Zone | | | +| | | | +| [[/Users/yuan/t/20200616151642.png]] | | | +| | | | +| | | | +| | | | +|----------------------------------+---+---| + +* Large table + +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | +| header file | compile time (s) | +|-----------------------------------------+------------------| +| =ks/reco/leaf/common.h= | 35.487 | +| =ks/reco/util/util_session_parameter.h= | 8.200 | +| =ks/reco/util/config_key.h= | 3.800 | +| =serving_base/util/kconf_util.h= | 3.526 | +| | | + + + +# Local Variables: +# eval: (visual-line-mode -1) +# End: diff --git a/homebase/public/.emacs.d/locext/valign/valign.el b/homebase/public/.emacs.d/locext/valign/valign.el new file mode 100644 index 00000000..873067ae --- /dev/null +++ b/homebase/public/.emacs.d/locext/valign/valign.el @@ -0,0 +1,1169 @@ +;;; valign.el --- Visually align tables -*- lexical-binding: t; -*- + +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. + +;; Author: Yuan Fu +;; Maintainer: Yuan Fu +;; URL: https://github.com/casouri/valign +;; Version: 3.1.1 +;; Keywords: convenience, text, table +;; Package-Requires: ((emacs "26.0")) + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; This package provides visual alignment for Org Mode, Markdown and +;; table.el tables on GUI Emacs. It can properly align tables +;; containing variable-pitch font, CJK characters and images. In the +;; meantime, the text-based alignment generated by Org mode (or +;; Markdown mode) is left untouched. +;; +;; To use this package, type M-x valign-mode RET. If you want to +;; align a table manually, run M-x valign-table RET on a table. If +;; you want to automatically enable this mode, add `valign-mode' to a +;; major mode hook like `org-mode-hook'. +;; +;; For table.el tables to work with valign, each cell has to have at +;; least one space on the right and no space on the left. You can use +;; ftable.el to auto-layout the table for you. +;; +;; TODO: +;; +;; - Hidden links in markdown still occupy the full length of the link +;; because it uses character composition, which we don’t support. +;; +;; Customization +;; +;; valign-fancy-bar If non-nil, use pretty vertical bars. +;; valign-not-align-after-list Valign doesn't align after these +;; commands. +;; valign-signal-parse-error If non-nil, emit parse errors. +;; valign-max-table-size Valign doesn't align tables of size +;; larger than this value. +;; valign-table-fallback Face for tables that are not aligned +;; because of their size. +;; +;; Uninteresting variables +;; +;; valign-lighter +;; valign-box-charset-alist + +;;; Developer: +;; +;; The trigger condition: +;; +;; We decide to re-align in the jit-lock hook, that means any change +;; that causes refontification will trigger a re-align. This may seem +;; inefficient and unnecessary, but there are just too many things +;; that can mess up a table’s alignment. Therefore it is the most +;; reliable to re-align every time there is a refontification. +;; However, we do have a small optimization for typing in a table: if +;; the last command is 'self-insert-command', we don’t realign. That +;; should improve the typing experience in large tables. +;; +;; How does valign align tables: +;; +;; The core mechanism used is a text property 'display. Emacs can +;; display a stretch of space that aligns to a pixel position. +;; The following snippet +;; +;; (put-text-property (point) (1+ (point)) +;; 'display '(space :align-to (500))) +;; +;; creates a space that stretches to pixel position 500. You can look +;; at Info node (elisp) “Display Property” for more detail. +;; +;; To align a table, we first look through all its cells to calculate +;; the appropriate column width, this is done by +;; `valign--calculate-cell-width'. Then we calculate the alignment of +;; each column (left/right-aligned) in `valign--calculate-alignment'. +;; Finally we align each cell by adding text property (or overlay) to +;; the spaces in the cell which “pushes” the bars to the appropriate +;; positions. +;; +;; Some important auxiliary functions: +;; +;; - valign--pixel-width-from-to +;; - valign--cell-content-config + +;;; Code: +;; + +(require 'cl-generic) +(require 'cl-lib) +(require 'pcase) + +(defgroup valign nil + "Visually align text tables on GUI." + :group 'text) + +(defcustom valign-lighter " valign" + "The lighter string used by function `valign-mode'." + :type 'string) + +(defcustom valign-fancy-bar nil + "Non-nil means to render bar as a full-height line. +You need to restart valign mode for this setting to take effect." + :type '(choice + (const :tag "Enable fancy bar" t) + (const :tag "Disable fancy bar" nil))) + +;;; Backstage + +(define-error 'valign-not-gui "Valign only works in GUI environment") +(define-error 'valign-not-on-table "Valign is asked to align a table, but the point is not on one") +(define-error 'valign-parse-error "Valign cannot parse the table") + +;;;; Table.el tables + +(defvar valign-box-charset-alist + '((ascii . " ++-++ +| || ++-++ ++-++") + (unicode . " +┌─┬┐ +│ ││ +├─┼┤ +└─┴┘")) + "An alist of (NAME . CHARSET). +A charset tells ftable how to parse the table. I.e., what are the +box drawing characters to use. Don’t forget the first newline. +NAME is the mnemonic for that charset.") + +(defun valign-box-char (code charset) + "Return a specific box drawing character in CHARSET. + +Return a string. CHARSET should be like `ftable-box-char-set'. +Mapping between CODE and position: + + ┌┬┐ 123 + ├┼┤ <-> 456 + └┴┘ 789 + + ┌─┐ 1 H 3 H: horizontal + │ │ <-> V V V: vertical + └─┘ 7 H 9 + +Examples: + + (ftable-box-char 'h charset) => \"─\" + (ftable-box-char 2 charset) => \"┬\"" + (let ((index (pcase code + ('h 10) + ('v 11) + ('n 12) + ('s 13) + (_ code)))) + + (char-to-string + (aref charset ; 1 2 3 4 5 6 7 8 9 H V N S + (nth index '(nil 1 3 4 11 13 14 16 18 19 2 6 0 7)))))) + +;;;; Auxilary + +(defun valign--cell-alignment () + "Return how is current cell aligned. +Return 'left if aligned left, 'right if aligned right. +Assumes point is after the left bar (“|”). +Doesn’t check if we are in a cell." + (save-excursion + (if (looking-at " [^ ]") + 'left + (if (not (search-forward "|" nil t)) + (signal + 'valign-parse-error + (list (format "Missing the right bar (|) around %s" (point)))) + (if (looking-back + "[^ ] |" (max (- (point) 3) (point-min))) + 'right + 'left))))) + +(defun valign--cell-content-config (&optional bar-char) + "Return (CELL-BEG CONTENT-BEG CONTENT-END CELL-END). +CELL-BEG is after the left bar, CELL-END is before the right bar. +CELL-CONTENT contains the actual non-white-space content, +possibly with a single white space padding on the either side, if +there are more than one white space on that side. + +If the cell is empty, CONTENT-BEG is + + (min (CELL-BEG + 1) CELL-END) + +CONTENT-END is + + (max (CELL-END - 1) CELL-BEG) + +BAR-CHAR is the separator character (“|”). It is actually a +string. Defaults to the normal bar: “|”, but you can provide a +Unicode one for Unicode tables. + +Assumes point is after the left bar (“|”). Assumes there is a +right bar." + (save-excursion + (let* ((bar-char (or bar-char "|")) + (cell-beg (point)) + (cell-end + (save-excursion + (unless (search-forward bar-char (line-end-position) t) + (signal 'valign-parse-error + (list (format + "Missing the right bar (|) around %d" + (line-end-position))))) + (match-beginning 0))) + ;; `content-beg-strict' is the beginning of the content + ;; excluding any white space. Same for `content-end-strict'. + content-beg-strict content-end-strict) + (if (save-excursion (skip-chars-forward " ") + (looking-at-p bar-char)) + ;; Empty cell. + (list cell-beg + (min (1+ cell-beg) cell-end) + (max (1- cell-end) cell-beg) + cell-end) + ;; Non-empty cell. + (skip-chars-forward " ") + (setq content-beg-strict (point)) + (goto-char cell-end) + (skip-chars-backward " ") + (setq content-end-strict (point)) + (when (and (= content-beg-strict cell-beg) + (= content-end-strict cell-end)) + (signal 'valign-parse-error `("The cell should contain at least one space" ,(buffer-substring-no-properties (1- cell-beg) (1+ cell-end))))) + ;; Calculate delimiters. Basically, we try to preserve a white + ;; space on the either side of the content, i.e., include them + ;; in (BEG . END). Because if you are typing in a cell and + ;; type a space, you probably want valign to keep that space + ;; as cell content, rather than to consider it as part of the + ;; padding and add overlay over it. + (list cell-beg + (if (<= (- content-beg-strict cell-beg) 1) + content-beg-strict + (1- content-beg-strict)) + (if (<= (- cell-end content-end-strict) 1) + content-end-strict + (1+ content-end-strict)) + cell-end))))) + +(defun valign--cell-empty-p () + "Return non-nil if cell is empty. +Assumes point is after the left bar (“|”)." + (save-excursion + (and (skip-chars-forward " ") + (looking-at "|")))) + +(defun valign--cell-content-width (&optional bar-char) + "Return the pixel width of the cell at point. +Assumes point is after the left bar (“|”). Return nil if not in +a cell. BAR-CHAR is the bar character (“|”)." + ;; We assumes: + ;; 1. Point is after the left bar (“|”). + ;; 2. Cell is delimited by either “|” or “+”. + ;; 3. There is at least one space on either side of the content, + ;; unless the cell is empty. + ;; IOW: CELL := (|) + ;; EMPTY := + + ;; NON-EMPTY := +++ + ;; DELIM := | or + + (pcase-let* ((`(,_a ,beg ,end ,_b) + (valign--cell-content-config bar-char))) + (valign--pixel-width-from-to beg end))) + +;; Sometimes, because of Org's table alignment, empty cell is longer +;; than non-empty cell. This usually happens with CJK text, because +;; CJK characters are shorter than 2x ASCII character but Org treats +;; CJK characters as 2 ASCII characters when aligning. And if you +;; have 16 CJK char in one cell, Org uses 32 ASCII spaces for the +;; empty cell, which is longer than 16 CJK chars. So better regard +;; empty cell as 0-width rather than measuring it's white spaces. +(defun valign--cell-nonempty-width (&optional bar-char) + "Return the pixel width of the cell at point. +If the cell is empty, return 0. Otherwise return cell content’s +width. BAR-CHAR is the bar character (“|”)." + (if (valign--cell-empty-p) 0 + (valign--cell-content-width bar-char))) + +;; We used to use a custom functions that calculates the pixel text +;; width that doesn’t require a live window. However that function +;; has some limitations, including not working right with face remapping. +;; With this function we can avoid some of them. However we still can’t +;; get the true tab width, see comment in ‘valgn--tab-width’ for more. +(defun valign--pixel-width-from-to (from to) + "Return the width of the glyphs from FROM (inclusive) to TO (exclusive). +The buffer has to be in a live window. FROM has to be less than +TO and they should be on the same line. Valign display +properties must be cleaned before using this." + (- (car (window-text-pixel-size + nil (line-beginning-position) to)) + (+ (car (window-text-pixel-size + nil (line-beginning-position) from)) + ;; HACK: You would expect (window-text-pixel-size WINDOW + ;; FROM TO) to return line-number-display-width when FROM + ;; equals to TO, but no, it returns 0. + (if (eq (line-beginning-position) from) + (line-number-display-width 'pixel) + 0)))) + +(defun valign--pixel-x (point) + "Return the x pixel position of POINT." + (- (car (window-text-pixel-size nil (line-beginning-position) point)) + (line-number-display-width 'pixel))) + +(defun valign--separator-p (&optional point) + "If the current cell is actually a separator. +POINT should be after the left bar (“|”), default to current point." + (or (eq (char-after point) ?:) ;; Markdown tables. + (eq (char-after point) ?-))) + +(defun valign--alignment-from-seperator () + "Return the alignment of this column. +Assumes point is after the left bar (“|”) of a separator +cell. We don’t distinguish between left and center aligned." + (save-excursion + (if (eq (char-after) ?:) + 'left + (skip-chars-forward "-") + (if (eq (char-after) ?:) + 'right + 'left)))) + +(defmacro valign--do-row (row-idx-sym limit &rest body) + "Go to each row’s beginning and evaluate BODY. +At each row, stop at the beginning of the line. Start from point +and stop at LIMIT. ROW-IDX-SYM is bound to each row’s +index (0-based)." + (declare (debug (sexp form &rest form)) + (indent 2)) + `(progn + (setq ,row-idx-sym 0) + (while (< (point) (min ,limit (point-max))) + (beginning-of-line) + ,@body + (forward-line) + (cl-incf ,row-idx-sym)))) + +(defmacro valign--do-column (column-idx-sym bar-char &rest body) + "Go to each column in the row and evaluate BODY. +Start from point and stop at the end of the line. Stop after the +cell bar (“|”) in each iteration. BAR-CHAR is \"|\" for the most +case. COLUMN-IDX-SYM is bound to the index of the +column (0-based)." + (declare (debug (sexp &rest form)) + (indent 2)) + `(progn + (setq ,column-idx-sym 0) + (beginning-of-line) + (while (search-forward ,bar-char (line-end-position) t) + ;; Unless we are after the last bar. + (unless (looking-at (format "[^%s]*\n" (regexp-quote ,bar-char))) + ,@body) + (cl-incf ,column-idx-sym)))) + +(defun valign--transpose (matrix) + "Transpose MATRIX." + (cl-loop for col-idx from 0 to (1- (length (car matrix))) + collect + (cl-loop for row in matrix + collect (nth col-idx row)))) + +(defun valign---check-dimension (matrix) + "Check that the dimension of MATRIX is correct. +Correct dimension means each row has the same number of columns. +Return t if the dimension is correct, nil if not." + (let ((first-row-column-count (length (car matrix)))) + (cl-loop for row in (cdr matrix) + if (not (eq first-row-column-count (length row))) + return nil + finally return t))) + +(defsubst valign--char-after-as-string (&optional pos) + "Return (char-after POS) as a string." + ;; (char-to-string (char-after)) doesn’t work because + ;; ‘char-to-string’ doesn’t accept nil. ‘if-let’ has some problems + ;; so I replaced it with ‘let’ and ‘if’ (See Bug #25 on GitHub). + (let ((ch (char-after pos))) + (if ch (char-to-string ch)))) + +(defun valign--separator-line-p (&optional charset) + "Return t if this line is a separator line. +If the table is a table.el table, you need to specify CHARSET. +If the table is not a table.el table, DON’T specify CHARSET. +Assumes the point is at the beginning of the line." + (save-excursion + (skip-chars-forward " \t") + (if charset + ;; Check for table.el tables. + (let ((charset (or charset (cdar valign-box-charset-alist)))) + (member (valign--char-after-as-string) + (list (valign-box-char 1 charset) + (valign-box-char 4 charset) + (valign-box-char 7 charset)))) + ;; Check for org/markdown tables. + (and (eq (char-after) ?|) + (valign--separator-p (1+ (point))))))) + +(defun valign--calculate-cell-width (limit &optional charset) + "Return a list of column widths. +Each column width is the largest cell width of the column. Start +from point, stop at LIMIT. If the table is a table.el table, you +need to specify CHARSET." + (let* ((bar-char (if charset (valign-box-char 'v charset) "|")) + row-idx column-idx matrix row) + (ignore row-idx) + (save-excursion + (valign--do-row row-idx limit + (unless (valign--separator-line-p charset) + (setq row nil) + (valign--do-column column-idx bar-char + ;; Point is after the left “|”. + (push (valign--cell-nonempty-width bar-char) row)) + (push (reverse row) matrix)))) + ;; Sanity check. + (unless (valign---check-dimension matrix) + (signal 'valign-parse-error '("The number of columns for each row don’t match, maybe a bar (|) is missing?"))) + (setq matrix (valign--transpose (reverse matrix))) + ;; Add 8 pixels of padding. + (mapcar (lambda (col) (+ (apply #'max col) 8)) matrix))) + +(cl-defmethod valign--calculate-alignment ((type (eql markdown)) limit) + "Return a list of alignments ('left or 'right) for each column. +TYPE must be 'markdown. Start at point, stop at LIMIT." + (ignore type) + (let (row-idx column-idx matrix row) + (ignore row-idx) + (save-excursion + (valign--do-row row-idx limit + (when (valign--separator-line-p) + (setq row nil) + (valign--do-column column-idx "|" + (push (valign--alignment-from-seperator) row)) + (push (reverse row) matrix)))) + ;; Sanity check. + (unless (valign---check-dimension matrix) + (signal 'valign-parse-error '("The number of columns for each row don’t match, maybe a bar (|) is missing?"))) + (setq matrix (valign--transpose (reverse matrix))) + (if matrix + (mapcar #'car matrix) + (dotimes (_ (or column-idx 0) matrix) + (push 'left matrix))))) + +(cl-defmethod valign--calculate-alignment ((type (eql org)) limit) + "Return a list of alignments ('left or 'right) for each column. +TYPE must be 'org. Start at point, stop at LIMIT." + ;; Why can’t infer the alignment on each cell by its space padding? + ;; Because the widest cell of a column has one space on both side, + ;; making it impossible to infer the alignment. + (ignore type) + (let (column-idx row-idx row matrix) + (ignore row-idx) + (save-excursion + (valign--do-row row-idx limit + (unless (valign--separator-line-p) + (setq row nil) + (valign--do-column column-idx "|" + (push (valign--cell-alignment) row)) + (push (reverse row) matrix))) + ;; Sanity check. + (unless (valign---check-dimension matrix) + (signal 'valign-parse-error '("The number of columns for each row don’t match, maybe a bar (|) is missing?"))) + (setq matrix (valign--transpose (reverse matrix))) + ;; For each column, we take the majority. + (mapcar (lambda (col) + (let ((left-count (cl-count 'left col)) + (right-count (cl-count 'right col))) + (if (> left-count right-count) + 'left 'right))) + matrix)))) + +(defun valign--at-table-p () + "Return non-nil if point is in a table." + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + ;; CHAR is the first character, CHAR 2 is the one after it. + (let ((char (valign--char-after-as-string)) + (char2 (valign--char-after-as-string (1+ (point))))) + (or (equal char "|") + (cl-loop + for elt in valign-box-charset-alist + for charset = (cdr elt) + if (or (equal char (valign-box-char 'v charset)) + (and (equal char + (valign-box-char 1 charset)) + (member char2 + (list (valign-box-char 2 charset) + (valign-box-char 3 charset) + (valign-box-char 'h charset)))) + (and (equal char + (valign-box-char 4 charset)) + (member char2 + (list (valign-box-char 5 charset) + (valign-box-char 6 charset) + (valign-box-char 'h charset)))) + (and (equal char + (valign-box-char 7 charset)) + (member char2 + (list (valign-box-char 8 charset) + (valign-box-char 9 charset) + (valign-box-char 'h charset))))) + return t + finally return nil))))) + +(defun valign--align-p () + "Return non-nil if we should align the table at point." + (save-excursion + (beginning-of-line) + (let ((face (plist-get (text-properties-at (point)) 'face))) + ;; Don’t align tables in org blocks. + (not (and (consp face) + (or (equal face '(org-block)) + (equal (plist-get face :inherit) + '(org-block)))))))) + +(defun valign--beginning-of-table () + "Go backward to the beginning of the table at point. +Assumes point is on a table." + ;; This implementation allows non-table lines before a table, e.g., + ;; #+latex: xxx + ;; |------+----| + (when (valign--at-table-p) + (beginning-of-line)) + (while (and (< (point-min) (point)) + (valign--at-table-p)) + (forward-line -1)) + (unless (valign--at-table-p) + (forward-line 1))) + +(defun valign--end-of-table () + "Go forward to the end of the table at point. +Assumes point is on a table." + (let ((start (point))) + (when (valign--at-table-p) + (beginning-of-line)) + (while (and (< (point) (point-max)) + (valign--at-table-p)) + (forward-line 1)) + (unless (<= (point) start) + (skip-chars-backward "\n")) + (when (< (point) start) + (error "End of table goes backwards")))) + +(defun valign--put-overlay (beg end &rest props) + "Put overlay between BEG and END. +PROPS contains properties and values." + (let ((ov (make-overlay beg end nil t nil))) + (overlay-put ov 'valign t) + (overlay-put ov 'evaporate t) + (while props + (overlay-put ov (pop props) (pop props))))) + +(defun valign--put-text-prop (beg end &rest props) + "Put text property between BEG and END. +PROPS contains properties and values." + (with-silent-modifications + (add-text-properties beg end props) + (put-text-property beg end 'valign t))) + +(defsubst valign--space (xpos) + "Return a display property that aligns to XPOS." + `(space :align-to (,xpos))) + +(defvar valign-fancy-bar) +(defun valign--maybe-render-bar (point) + "Make the character at POINT a full height bar. +But only if `valign-fancy-bar' is non-nil." + (when valign-fancy-bar + (valign--render-bar point))) + +(defun valign--fancy-bar-cursor-fn (window prev-pos action) + "Run when point enters or left a fancy bar. +Because the bar is so thin, the cursor disappears in it. We +expands the bar so the cursor is visible. 'cursor-intangible +doesn’t work because it prohibits you to put the cursor at BOL. + +WINDOW is just window, PREV-POS is the previous point of cursor +before event, ACTION is either 'entered or 'left." + (ignore window) + (with-silent-modifications + (let ((ov-list (overlays-at (pcase action + ('entered (point)) + ('left prev-pos))))) + (dolist (ov ov-list) + (when (overlay-get ov 'valign-bar) + (overlay-put + ov 'display (pcase action + ('entered (if (eq cursor-type 'bar) + '(space :width (3)) " ")) + ('left '(space :width (1)))))))))) + +(defun valign--render-bar (point) + "Make the character at POINT a full-height bar." + (with-silent-modifications + (put-text-property point (1+ point) + 'cursor-sensor-functions + '(valign--fancy-bar-cursor-fn)) + (valign--put-overlay point (1+ point) + 'face '(:inverse-video t) + 'display '(space :width (1)) + 'valign-bar t))) + +(defun valign--clean-text-property (beg end) + "Clean up the display text property between BEG and END." + (with-silent-modifications + (put-text-property beg end 'cursor-sensor-functions nil)) + ;; Remove overlays. + (let ((ov-list (overlays-in beg end))) + (dolist (ov ov-list) + (when (overlay-get ov 'valign) + (delete-overlay ov)))) + ;; Remove text properties. + (let ((p beg) tab-end (last-p -1)) + (while (not (eq p last-p)) + (when (plist-get (text-properties-at p) 'valign) + ;; We are at the beginning of a tab, now find the end. + (setq tab-end (next-single-char-property-change + p 'valign nil end)) + ;; Remove text property. + (with-silent-modifications + (put-text-property p tab-end 'display nil) + (put-text-property p tab-end 'valign nil))) + (setq last-p p + p (next-single-char-property-change p 'valign nil end))))) + +(defun valign--glyph-width-of (string point) + "Return the pixel width of STRING with font at POINT. +STRING should have length 1." + (aref (aref (font-get-glyphs (font-at point) 0 1 string) 0) 4)) + +(defun valign--separator-row-add-overlay (beg end right-pos) + "Add overlay to a separator row’s “cell”. +Cell ranges from BEG to END, the pixel position RIGHT-POS marks +the position for the right bar (“|”). +Assumes point is on the right bar or plus sign." + ;; Make “+” look like “|” + (if valign-fancy-bar + ;; Render the right bar. + (valign--render-bar end) + (when (eq (char-after end) ?+) + (let ((ov (make-overlay end (1+ end)))) + (overlay-put ov 'display "|") + (overlay-put ov 'valign t)))) + ;; Markdown row + (when (eq (char-after beg) ?:) + (setq beg (1+ beg))) + (when (eq (char-before end) ?:) + (setq end (1- end) + right-pos (- right-pos + (valign--pixel-width-from-to (1- end) end)))) + ;; End of Markdown + (valign--put-overlay beg end + 'display (valign--space right-pos) + 'face '(:strike-through t))) + +(defun valign--align-separator-row (column-width-list) + "Align the separator row in multi column style. +COLUMN-WIDTH-LIST is returned by `valign--calculate-cell-width'." + (let ((bar-width (valign--glyph-width-of "|" (point))) + (space-width (valign--glyph-width-of " " (point))) + (column-start (point)) + (col-idx 0) + (pos (valign--pixel-x (point)))) + ;; Render the first left bar. + (valign--maybe-render-bar (1- (point))) + ;; Add overlay in each column. + (while (re-search-forward "[|\\+]" (line-end-position) t) + ;; Render the right bar. + (valign--maybe-render-bar (1- (point))) + (let ((column-width (nth col-idx column-width-list))) + (valign--separator-row-add-overlay + column-start (1- (point)) (+ pos column-width space-width)) + (setq column-start (point) + pos (+ pos column-width bar-width space-width)) + (cl-incf col-idx))))) + +(defun valign--guess-table-type () + "Return either 'org or 'markdown." + (cond ((derived-mode-p 'org-mode 'org-agenda-mode) 'org) + ((derived-mode-p 'markdown-mode) 'markdown) + ((string-match-p "org" (symbol-name major-mode)) 'org) + ((string-match-p "markdown" (symbol-name major-mode)) 'markdown) + (t 'org))) + + +;;; Align + +(defcustom valign-not-align-after-list '(self-insert-command + org-self-insert-command + markdown-outdent-or-delete + org-delete-backward-char + backward-kill-word + delete-char + kill-word) + "Valign doesn’t align table after these commands." + :type '(list symbol) + :group 'valign) + +(defvar valign-signal-parse-error nil + "When non-nil and ‘debug-on-error’, signal parse error. +If ‘debug-on-error’ is also non-nil, drop into the debugger.") + +(defcustom valign-max-table-size 4000 + "Valign doesn't align tables of size larger than this value. +Valign puts `valign-table-fallback' face onto these tables. If the +value is zero, valign doesn't check for table sizes." + :type 'integer + :group 'valign) + +(defface valign-table-fallback + '((t . (:inherit fixed-pitch))) + "Fallback face for tables whose size exceeds `valign-max-table-size'." + :group 'valign) + +(defun valign-table-maybe (&optional force go-to-end) + "Visually align the table at point. +If FORCE non-nil, force align. If GO-TO-END non-nil, leave point +at the end of the table." + (condition-case err + (when (and (display-graphic-p) + (valign--at-table-p) + (valign--align-p) + (or force + (not (memq (or this-command last-command) + valign-not-align-after-list)))) + (save-excursion + (valign--beginning-of-table) + (let ((table-beg (point)) + (table-end (save-excursion + (valign--end-of-table) + (point)))) + (if (or (eq valign-max-table-size 0) + (<= (- table-end table-beg) valign-max-table-size)) + (if (valign--guess-charset) + (valign--table-2) + (valign-table-1)) + ;; Can't align the table, put fallback-face on. + (valign--clean-text-property table-beg table-end) + (valign--put-overlay table-beg table-end + 'face 'valign-table-fallback)))) + (when go-to-end (valign--end-of-table))) + + ((valign-parse-error error) + (valign--clean-text-property + (save-excursion (valign--beginning-of-table) (point)) + (save-excursion (valign--end-of-table) (point))) + (when (and (eq (car err) 'valign-parse-error) + valign-signal-parse-error) + (if debug-on-error + (debug 'valign-parse-error) + (message "%s" (error-message-string err))))))) + +(defun valign-table-1 () + "Visually align the table at point." + (valign--beginning-of-table) + (let* ((space-width (valign--glyph-width-of " " (point))) + (bar-width (valign--glyph-width-of "|" (point))) + (table-beg (point)) + (table-end (save-excursion (valign--end-of-table) (point))) + ;; Very hacky, but.. + (_ (valign--clean-text-property table-beg table-end)) + (column-width-list (valign--calculate-cell-width table-end)) + (column-alignment-list (valign--calculate-alignment + (valign--guess-table-type) table-end)) + row-idx column-idx column-start) + (ignore row-idx) + + ;; Align each row. + (valign--do-row row-idx table-end + (unless (search-forward "|" (line-end-position) t) + (signal 'valign-parse-error + (list (format "Missing the right bar (|) around %s" + (point))))) + (if (valign--separator-p) + ;; Separator row. + (valign--align-separator-row column-width-list) + + ;; Not separator row, align each cell. ‘column-start’ is the + ;; pixel position of the current point, i.e., after the left + ;; bar. + (setq column-start (valign--pixel-x (point))) + + (valign--do-column column-idx "|" + (save-excursion + ;; We are after the left bar (“|”). + ;; Render the left bar. + (valign--maybe-render-bar (1- (point))) + ;; Start aligning this cell. + ;; Pixel width of the column. + (let* ((col-width (nth column-idx column-width-list)) + ;; left or right aligned. + (alignment (nth column-idx column-alignment-list)) + ;; Pixel width of the cell. + (cell-width (valign--cell-content-width))) + ;; Align cell. + (pcase-let ((`(,cell-beg ,content-beg + ,content-end ,cell-end) + (valign--cell-content-config))) + (valign--cell col-width alignment cell-width + cell-beg content-beg + content-end cell-end + column-start space-width)) + ;; Update ‘column-start’ for the next cell. + (setq column-start (+ column-start col-width + bar-width space-width))))) + ;; Now we are at the last right bar. + (valign--maybe-render-bar (1- (point))))))) + +(defun valign--cell (col-width alignment cell-width + cell-beg content-beg + content-end cell-end + column-start space-width) + "Align the cell at point. + +For an example cell: + +| content content | + ↑ ↑ ↑ ↑ + 1 2 3 4 + <------5------> + <--------6----------> + +COL-WIDTH (6) Pixel width of the column +ALIGNMENT 'left or 'right +CELL-WIDTH (5) Pixel width of the cell content +CELL-BEG (1) Beginning of the cell +CONTENT-BEG (2) Beginning of the cell content[1] +CONTENT-END (3) End of the cell content[1] +CELL-END (4) End of the cell +COLUMN-START (1) Pixel x-position of the beginning of the cell +SPACE-WIDTH Pixel width of a space character + +Assumes point is at (2). + +[1] This is not completely true, see `valign--cell-content-config'." + (cl-labels ((valign--put-ov + (beg end xpos) + (valign--put-overlay beg end 'display + (valign--space xpos)))) + (cond ((= cell-beg content-beg) + ;; This cell has only one space. + (valign--put-ov + cell-beg cell-end + (+ column-start col-width space-width))) + ;; Empty cell. Sometimes empty cells are + ;; longer than other non-empty cells (see + ;; `valign--cell-width'), so we put overlay on + ;; all but the first white space. + ((valign--cell-empty-p) + (valign--put-ov + content-beg cell-end + (+ column-start col-width space-width))) + ;; A normal cell. + (t + (pcase alignment + ;; Align a left-aligned cell. + ('left (valign--put-ov content-end cell-end + (+ column-start + col-width space-width))) + ;; Align a right-aligned cell. + ('right (valign--put-ov + cell-beg content-beg + (+ column-start + (- col-width cell-width))))))))) + +(defun valign--table-2 () + "Visually align the table.el table at point." + ;; Instead of overlays, we use text properties in this function. + ;; Too many overlays degrades performance, and we add a whole bunch + ;; of them in this function, so better use text properties. + (valign--beginning-of-table) + (let* ((charset (valign--guess-charset)) + (ucharset (alist-get 'unicode valign-box-charset-alist)) + (table-beg (point)) + (table-end (save-excursion (valign--end-of-table) (point))) + ;; Very hacky, but.. + (_ (valign--clean-text-property table-beg table-end)) + ;; Measure char width after cleaning text properties. + ;; Otherwise the measurement is not accurate. + (char-width (with-silent-modifications + (insert (valign-box-char 'h ucharset)) + (prog1 (valign--pixel-width-from-to + (1- (point)) (point)) + (backward-delete-char 1)))) + (column-width-list + ;; Make every width multiples of CHAR-WIDTH. + (mapcar (lambda (x) + ;; Remove the 8 pixels of padding added by + ;; `valign--calculate-cell-width'. + (* char-width (1+ (/ (- x 8) char-width)))) + (valign--calculate-cell-width table-end charset))) + (row-idx 0) + (column-idx 0) + (column-start 0)) + (while (< (point) table-end) + (save-excursion + (skip-chars-forward " \t") + (if (not (equal (valign--char-after-as-string) + (valign-box-char 'v charset))) + ;; Render separator line. + (valign--align-separator-row-full + column-width-list + (cond ((valign--first-line-p table-beg table-end) + '(1 2 3)) + ((valign--last-line-p table-beg table-end) + '(7 8 9)) + (t '(4 5 6))) + charset char-width) + ;; Render normal line. + (setq column-start (valign--pixel-x (point)) + column-idx 0) + (while (search-forward (valign-box-char 'v charset) + (line-end-position) t) + (valign--put-text-prop + (1- (point)) (point) + 'display (valign-box-char 'v ucharset)) + (unless (looking-at "\n") + (pcase-let ((col-width (nth column-idx column-width-list)) + (`(,cell-beg ,content-beg + ,content-end ,cell-end) + (valign--cell-content-config + (valign-box-char 'v charset)))) + (valign--put-text-prop + content-end cell-end 'display + (valign--space (+ column-start col-width char-width))) + (cl-incf column-idx) + (setq column-start + (+ column-start col-width char-width))))))) + (cl-incf row-idx) + (forward-line)))) + +(defun valign--first-line-p (beg end) + "Return t if the point is in the first line between BEG and END." + (ignore end) + (save-excursion + (not (search-backward "\n" beg t)))) + +(defun valign--last-line-p (beg end) + "Return t if the point is in the last line between BEG and END." + (ignore beg) + (save-excursion + (not (search-forward "\n" end t)))) + +(defun valign--align-separator-row-full + (column-width-list codeset charset char-width) + "Align separator row for a full table (table.el table). + +COLUMN-WIDTH-LIST is a list of column widths. CODESET is a list +of codes that corresponds to the left, middle and right box +drawing character codes to pass to `valign-box-char'. It can +be (1 2 3), (4 5 6), or (7 8 9). CHARSET is the same as in +`valign-box-charset-alist'. CHAR-WIDTH is the pixel width of a +character. + +Assumes point before the first character." + (let* ((middle (valign-box-char (nth 1 codeset) charset)) + (right (valign-box-char (nth 2 codeset) charset)) + ;; UNICODE-CHARSET is used for overlay, CHARSET is used for + ;; the physical table. + (unicode-charset (alist-get 'unicode valign-box-charset-alist)) + (uleft (valign-box-char (nth 0 codeset) unicode-charset)) + (umiddle (valign-box-char (nth 1 codeset) unicode-charset)) + (uright (valign-box-char (nth 2 codeset) unicode-charset)) + ;; Aka unicode horizontal. + (uh (valign-box-char 'h unicode-charset)) + (eol (line-end-position)) + (col-idx 0)) + (valign--put-text-prop (point) (1+ (point)) 'display uleft) + (goto-char (1+ (point))) + (while (re-search-forward (rx-to-string `(or ,middle ,right)) eol t) + ;; Render joints. + (if (looking-at "\n") + (valign--put-text-prop (1- (point)) (point) 'display uright) + (valign--put-text-prop (1- (point)) (point) 'display umiddle)) + ;; Render horizontal lines. + (save-excursion + (let ((p (1- (point))) + (width (nth col-idx column-width-list))) + (goto-char p) + (skip-chars-backward (valign-box-char 'h charset)) + (valign--put-text-prop (point) p 'display + (make-string (/ width char-width) + (aref uh 0))))) + (cl-incf col-idx)))) + +(defun valign--guess-charset () + "Return the charset used by the table at point. +Assumes point at the beginning of the table." + (cl-loop for charset + in (mapcar #'cdr valign-box-charset-alist) + if (equal (valign--char-after-as-string) + (valign-box-char 1 charset)) + return charset + finally return nil)) + +;;; Mode intergration + +(defun valign-region (&optional beg end) + "Align tables between BEG and END. +Supposed to be called from jit-lock. +Force align if FORCE non-nil." + ;; Text sized can differ between frames, only use current frame. + ;; We only align when this buffer is in a live window, because we + ;; need ‘window-text-pixel-size’ to calculate text size. + (let* ((beg (or beg (point-min))) + (end (or end (point-max))) + (fontified-end end) + (table-beg-list + (cons "|" (cl-loop for elt in valign-box-charset-alist + for charset = (cdr elt) + collect (valign-box-char 1 charset)))) + (table-re (rx-to-string `(or ,@table-beg-list)))) + (when (window-live-p (get-buffer-window nil (selected-frame))) + (save-excursion + (goto-char beg) + (while (and (< (point) end) + (re-search-forward table-re end t)) + (condition-case err + (valign-table-maybe nil t) + (error (message "Error when aligning table: %s" + (error-message-string err)))) + (setq fontified-end (point))))) + (cons 'jit-lock-bounds (cons beg (max end fontified-end))))) + +(defvar valign-mode) +(defun valign--buffer-advice (&rest _) + "Realign whole buffer." + (when valign-mode + (valign-region))) + +(defvar org-indent-agentized-buffers) +(defun valign--org-indent-advice (&rest _) + "Re-align after org-indent is done." + ;; See ‘org-indent-initialize-agent’. + (when (not org-indent-agentized-buffers) + (valign--buffer-advice))) + +;; When an org link is in an outline fold, it’s full length +;; is used, when the subtree is unveiled, org link only shows +;; part of it’s text, so we need to re-align. This function +;; runs after the region is flagged. When the text +;; is shown, jit-lock will make valign realign the text. +(defun valign--flag-region-advice (beg end flag &optional _) + "Valign hook, realign table between BEG and END. +FLAG is the same as in ‘org-flag-region’." + (when (and valign-mode (not flag)) + (with-silent-modifications + ;; Outline has a bug that passes 0 as a buffer position + ;; to `org-flag-region', so we need to patch that up. + (put-text-property (max 1 beg) end 'fontified nil)))) + +(defun valign--tab-advice (&rest _) + "Force realign after tab so user can force realign." + (when (and valign-mode + (valign--at-table-p) + (valign--align-p)) + (valign-table))) + +(defun valign-reset-buffer () + "Remove alignment in the buffer." + (with-silent-modifications + (valign--clean-text-property (point-min) (point-max)) + (jit-lock-refontify))) + +(defun valign-remove-advice () + "Remove advices added by valign." + (interactive) + (dolist (fn '(org-cycle + org-table-blank-field + markdown-cycle)) + (advice-remove fn #'valign--tab-advice)) + (dolist (fn '(text-scale-increase + text-scale-decrease + org-toggle-inline-images)) + (advice-remove fn #'valign--buffer-advice)) + (dolist (fn '(org-flag-region outline-flag-region)) + (advice-remove fn #'valign--flag-region-advice)) + (when (featurep 'org-indent) + (advice-remove 'org-indent-initialize-agent + #'valign--org-indent-advice))) + +(defun valign--maybe-clean-advice () + "Remove advices if there is no buffer with valign-mode enabled. +This runs in `kill-buffer-hook'." + (when (eq 1 (cl-count-if + (lambda (buf) + (buffer-local-value 'valign-mode buf)) + (buffer-list))) + (valign-remove-advice))) + +;;; Userland + +;;;###autoload +(defun valign-table () + "Visually align the table at point." + (interactive) + (valign-table-maybe t)) + +;;;###autoload +(define-minor-mode valign-mode + "Visually align Org tables." + :require 'valign + :group 'valign + :lighter valign-lighter + (if (not (display-graphic-p)) + (when valign-mode + (message "Valign mode has no effect in non-graphical display")) + (if valign-mode + (progn + (add-hook 'jit-lock-functions #'valign-region 98 t) + (dolist (fn '(org-cycle + ;; Why this function? If you tab into an org + ;; field (cell) and start typing right away, + ;; org clears that field for you with this + ;; function. The problem is, this functions + ;; messes up the overlay and makes the bar + ;; invisible. So we have to fix the overlay + ;; after this function. + org-table-blank-field + markdown-cycle)) + (advice-add fn :after #'valign--tab-advice)) + (dolist (fn '(text-scale-increase + text-scale-decrease + org-toggle-inline-images)) + (advice-add fn :after #'valign--buffer-advice)) + (dolist (fn '(org-flag-region outline-flag-region)) + (advice-add fn :after #'valign--flag-region-advice)) + (when (featurep 'org-indent) + (advice-add 'org-indent-initialize-agent + :after #'valign--org-indent-advice)) + (add-hook 'org-indent-mode-hook #'valign--buffer-advice 0 t) + (add-hook 'kill-buffer-hook #'valign--maybe-clean-advice 0 t) + (if valign-fancy-bar (cursor-sensor-mode)) + (jit-lock-refontify)) + (remove-hook 'jit-lock-functions #'valign-region t) + (remove-hook 'kill-buffer-hook #'valign--maybe-clean-advice t) + (valign-reset-buffer) + (cursor-sensor-mode -1) + (valign--maybe-clean-advice)))) + +(provide 'valign) + +;;; valign.el ends here + +;; Local Variables: +;; sentence-end-double-space: t +;; End: