commit e1266f50574ec3e21a1a1c368d4ebef760a9dd35 Author: MrZaiko Date: Sat Apr 12 09:42:15 2025 +0200 Add current doom config diff --git a/config.el b/config.el new file mode 100644 index 0000000..a47e6ab --- /dev/null +++ b/config.el @@ -0,0 +1,379 @@ +;;; $DOOMDIR/config.el -*- lexical-binding: t; -*- + +;; Place your private configuration here! Remember, you do not need to run 'doom +;; sync' after modifying this file! + + +;; Some functionality uses this to identify you, e.g. GPG configuration, email +;; clients, file templates and snippets. It is optional. +;; (setq user-full-name "John Doe" +;; user-mail-address "john@doe.com") + +;; Doom exposes five (optional) variables for controlling fonts in Doom: +;; +;; - `doom-font' -- the primary font to use +;; - `doom-variable-pitch-font' -- a non-monospace font (where applicable) +;; - `doom-big-font' -- used for `doom-big-font-mode'; use this for +;; presentations or streaming. +;; - `doom-symbol-font' -- for symbols +;; - `doom-serif-font' -- for the `fixed-pitch-serif' face +;; +;; See 'C-h v doom-font' for documentation and more examples of what they +;; accept. For example: +;; +;;(setq doom-font (font-spec :family "Fira Code" :size 12 :weight 'semi-light) +;; doom-variable-pitch-font (font-spec :family "Fira Sans" :size 13)) +;; +;; If you or Emacs can't find your font, use 'M-x describe-font' to look them +;; up, `M-x eval-region' to execute elisp code, and 'M-x doom/reload-font' to +;; refresh your font settings. If Emacs still can't find your font, it likely +;; wasn't installed correctly. Font issues are rarely Doom issues! + +;; There are two ways to load a theme. Both assume the theme is installed and +;; available. You can either set `doom-theme' or manually load a theme with the +;; `load-theme' function. This is the default: +(setq doom-theme 'doom-one) +;;(load-theme 'catppuccin :no-confirm) + +;; This determines the style of line numbers in effect. If set to `nil', line +;; numbers are disabled. For relative line numbers, set this to `relative'. +(setq display-line-numbers-type t) + +;; If you use `org' and don't want your org files in the default location below, +;; change `org-directory'. It must be set before org loads! +(setq org-directory "~/Documents/Org") +(setq org-roam-directory (file-truename "~/Documents/Org/roam")) ;; Set the directory for your notes + +;;(setq doom-font (font-spec :family "Roboto Mono" :size 13)) +(when (member "Roboto Mono" (font-family-list)) + (set-face-attribute 'default nil :font "Roboto Mono" :height 110) + (set-face-attribute 'fixed-pitch nil :family "Roboto Mono")) + +(when (member "Source Sans 3" (font-family-list)) + (set-face-attribute 'variable-pitch nil :family "Source Sans 3" :height 1.25)) + +;; Whenever you reconfigure a package, make sure to wrap your config in an +;; `after!' block, otherwise Doom's defaults may override your settings. E.g. +;; +;; (after! PACKAGE +;; (setq x y)) +;; +;; The exceptions to this rule: +;; +;; - Setting file/directory variables (like `org-directory') +;; - Setting variables which explicitly tell you to set them before their +;; package is loaded (see 'C-h v VARIABLE' to look up their documentation). +;; - Setting doom variables (which start with 'doom-' or '+'). +;; +;; Here are some additional functions/macros that will help you configure Doom. +;; +;; - `load!' for loading external *.el files relative to this one +;; - `use-package!' for configuring packages +;; - `after!' for running code after a package has loaded +;; - `add-load-path!' for adding directories to the `load-path', relative to +;; this file. Emacs searches the `load-path' when you load packages with +;; `require' or `use-package'. +;; - `map!' for binding new keys +;; +;; To get information about any of these functions/macros, move the cursor over +;; the highlighted symbol at press 'K' (non-evil users must press 'C-c c k'). +;; This will open documentation for it, including demos of how they are used. +;; Alternatively, use `C-h o' to look up a symbol (functions, variables, faces, +;; etc). +;; +;; You can also try 'gd' (or 'C-c c d') to jump to their definition and see how +;; they are implemented. +;; + +(use-package! copilot + :hook (prog-mode . copilot-mode) + :bind (:map copilot-completion-map + ("" . 'copilot-accept-completion) + ("TAB" . 'copilot-accept-completion) + ("C-TAB" . 'copilot-accept-completion-by-word) + ("C-" . 'copilot-accept-completion-by-word) + ("C-n" . 'copilot-next-completion) + ("C-p" . 'copilot-previous-completion)) + + :config + (add-to-list 'copilot-indentation-alist '(prog-mode 2)) + (add-to-list 'copilot-indentation-alist '(org-mode 2)) + (add-to-list 'copilot-indentation-alist '(text-mode 2)) + (add-to-list 'copilot-indentation-alist '(closure-mode 2)) + (add-to-list 'copilot-indentation-alist '(emacs-lisp-mode 2))) + +;; ============================================================== +;; Shortcuts +;; ============================================================== + +;; check OS type +(cond + ((string-equal system-type "windows-nt") ; Microsoft Windows + (progn + (message "Microsoft Windows"))) + ((string-equal system-type "darwin") ; Mac OS X + (progn + (setq mac-option-key-is-meta nil) + (setq mac-command-key-is-meta t) + (setq mac-command-modifier 'meta) + (setq mac-option-modifier nil) + (message "Mac OS X"))) + ((string-equal system-type "gnu/linux") ; linux + (progn + (message "Linux")))) + +;; Copy to system clipboard with M-c +(global-set-key (kbd "M-c") 'clipboard-kill-ring-save) + +;; Paste from system clipboard with M-v +(global-set-key (kbd "M-v") 'clipboard-yank) + +;; Zoom in with C-+ +(global-set-key (kbd "C-=") 'text-scale-increase) + +;; Zoom out with C-- +(global-set-key (kbd "C--") 'text-scale-decrease) + +;; Scroll up one screen with C-S-v +(global-set-key (kbd "C-S-v") 'scroll-down-command) + +;; Select next occurences of a word +(global-set-key (kbd "C-d") 'mc/mark-next-like-this-symbol) + + +;; ============================================================== +;; Coq +;; ============================================================== + +(add-hook 'coq-mode-hook #'company-coq-mode) +(add-hook 'coq-mode-hook (lambda () (local-set-key (kbd "C-") #'proof-assert-next-command-interactive))) +(add-hook 'coq-mode-hook (lambda () (local-set-key (kbd "C-") #'proof-retract-until-point-interactive))) + +;;============================================================== +;; Org mode +;; ============================================================= + +(use-package vulpea + :ensure t + ;; hook into org-roam-db-autosync-mode you wish to enable + ;; persistence of meta values (see respective section in README to + ;; find out what meta means) + :hook ((org-roam-db-autosync-mode . vulpea-db-autosync-enable))) + +;; ================== Appearance ================== +;; Improve org mode looks +(use-package org-indent) +(set-face-attribute 'org-indent nil :inherit '(org-hide fixed-pitch)) + +(use-package olivetti) + +(use-package org-appear + :hook + (org-mode . org-appear-mode)) + +(use-package! org-modern + :hook + (org-mode . global-org-modern-mode) + :config + (setq + org-auto-align-tags t + org-tags-column 0 + org-fold-catch-invisible-edits 'show-and-error + org-special-ctrl-a/e t + org-insert-heading-respect-content t + + ;; Don't style the following + org-modern-tag nil + org-modern-todo nil + org-modern-priority nil) + + (global-org-modern-mode)) + +;; Resize Org headings +(dolist (face '((org-level-1 . 1.4) + (org-level-2 . 1.3) + (org-level-3 . 1.2) + (org-level-4 . 1.1) + (org-level-5 . 1.1) + (org-level-6 . 1.1) + (org-level-7 . 1.1) + (org-level-8 . 1.1))) + (set-face-attribute (car face) nil :family "Source Sans 3" :weight 'bold :height (cdr face))) + +;; Make the document title a bit bigger +(set-face-attribute 'org-document-title nil + :family "Source Sans 3" + :weight 'bold + :height 1.8) + +(add-hook 'org-mode-hook 'variable-pitch-mode) +(add-hook 'org-mode-hook 'visual-line-mode) +(add-hook 'org-mode-hook (lambda () (display-line-numbers-mode 0))) + +(set-face-attribute 'org-block nil :foreground nil :inherit + 'fixed-pitch :height 0.85) +(set-face-attribute 'org-code nil :inherit '(shadow fixed-pitch) :height 0.85) +(set-face-attribute 'org-indent nil :inherit '(org-hide fixed-pitch) :height 0.85) +(set-face-attribute 'org-verbatim nil :inherit '(shadow fixed-pitch) :height 0.85) +(set-face-attribute 'org-special-keyword nil :inherit '(font-lock-comment-face + fixed-pitch)) +(set-face-attribute 'org-meta-line nil :inherit '(font-lock-comment-face fixed-pitch)) +(set-face-attribute 'org-checkbox nil :inherit 'fixed-pitch) +(set-face-attribute 'org-table nil :inherit 'fixed-pitch) + + +(plist-put org-format-latex-options :scale 2) + +;; Use major mode of a specific language in an SRC block +(setq org-src-fontify-natively t + org-src-tab-acts-natively t + org-edit-src-content-indentation 0) + +(add-hook 'org-mode-hook 'olivetti-mode) + +;; ORG TODO +(setq org-lowest-priority ?F) ;; Gives us priorities A through F +(setq org-default-priority ?E) ;; If an item has no priority, it is considered [#E]. + +(setq org-priority-faces + '((65 . "#BF616A") + (66 . "#EBCB8B") + (67 . "#B48EAD") + (68 . "#81A1C1") + (69 . "#5E81AC") + (70 . "#4C566A"))) + +(setq org-todo-keywords + '((sequence + "TODO" "PROJ" "READ" "CHECK" "IDEA" ; Needs further action + "|" + "DONE"))) ; Needs no action currently + +(setq org-todo-keyword-faces + '(("TODO" :inherit (org-todo region) :foreground "#A3BE8C" :weight bold) + ("PROJ" :inherit (org-todo region) :foreground "#88C0D0" :weight bold) + ("READ" :inherit (org-todo region) :foreground "#8FBCBB" :weight bold) + ("CHECK" :inherit (org-todo region) :foreground "#81A1C1" :weight bold) + ("IDEA" :inherit (org-todo region) :foreground "#EBCB8B" :weight bold) + ("DONE" :inherit (org-todo region) :foreground "#30343d" :weight bold))) + +(setq org-startup-indented t + org-pretty-entities t + org-use-sub-superscripts "{}" + org-hide-emphasis-markers t + org-startup-with-inline-images t + org-image-actual-width '(300)) + +(setq org-support-shift-select t) + +(add-to-list 'load-path "~/.doom.d/") +(setq org-startup-truncated nil) +(with-eval-after-load "org" + (require 'org-phscroll)) + +;; ================== ORG Roam ================== + +(use-package! org-roam + :config + (org-roam-db-autosync-mode)) ;; Automatically sync the roam database + +(setq org-roam-completion-everywhere t) ;; Enable Org-roam completions globally + +(setq org-roam-mode-sections + '(org-roam-backlinks-section ;; Show backlinks + org-roam-reflinks-section ;; Show references (if applicable) + org-roam-unlinked-references-section)) ;; Show unlinked references + +;; ================== Shortcuts ================== + +(global-set-key (kbd "C-o") 'org-open-at-point) +(global-set-key (kbd "M-o") 'org-mark-ring-goto) + +;; Insert a not without opening it +(defun org-roam-node-insert-immediate (arg &rest args) + (interactive "P") + (let ((args (cons arg args)) + (org-roam-capture-templates (list (append (car org-roam-capture-templates) + '(:immediate-finish t))))) + (apply #'org-roam-node-insert args))) + +(global-set-key (kbd "C-c n r I") 'org-roam-node-insert-immediate) + +;;paste image from clipboard +(use-package! org-download) + +(setq org-download-image-dir "images") +(after! org-download + (setq org-download-method 'directory)) +(setq org-download-heading-lvl nil) +(setq org-download-timestamp "%Y%m%d-%H%M%S_") +(setq org-image-actual-width 300) +(map! :map org-mode-map + "C-c n r v" 'org-download-clipboard) + +;; ================== Agenda ================== +;; Auto add roam file with TODO to the agenda + +(defun vulpea-project-p () + "Return non-nil if current buffer has any todo entry. + +TODO entries marked as done are ignored, meaning the this +function returns nil if current buffer contains only completed +tasks." + (seq-find ; (3) + (lambda (type) + (eq type 'todo)) + (org-element-map ; (2) + (org-element-parse-buffer 'headline) ; (1) + 'headline + (lambda (h) + (org-element-property :todo-type h))))) + +(defun vulpea-project-update-tag () + "Update PROJECT tag in the current buffer." + (when (and (not (active-minibuffer-window)) + (vulpea-buffer-p)) + (save-excursion + (goto-char (point-min)) + (let* ((tags (vulpea-buffer-tags-get)) + (original-tags tags)) + (if (vulpea-project-p) + (setq tags (cons "project" tags)) + (setq tags (remove "project" tags))) + + ;; cleanup duplicates + (setq tags (seq-uniq tags)) + + ;; update tags if changed + (when (or (seq-difference tags original-tags) + (seq-difference original-tags tags)) + (apply #'vulpea-buffer-tags-set tags)))))) + +(defun vulpea-buffer-p () + "Return non-nil if the currently visited buffer is a note." + (and buffer-file-name + (string-prefix-p + (expand-file-name (file-name-as-directory org-roam-directory)) + (file-name-directory buffer-file-name)))) + +(defun vulpea-project-files () + "Return a list of note files containing 'project' tag." ; + (seq-uniq + (seq-map + #'car + (org-roam-db-query + [:select [nodes:file] + :from tags + :left-join nodes + :on (= tags:node-id nodes:id) + :where (like tag (quote "%\"project\"%"))])))) + +(defun vulpea-agenda-files-update (&rest _) + "Update the value of `org-agenda-files'." + (setq org-agenda-files (vulpea-project-files))) + +(add-hook 'find-file-hook #'vulpea-project-update-tag) +(add-hook 'before-save-hook #'vulpea-project-update-tag) + +(advice-add 'org-agenda :before #'vulpea-agenda-files-update) +(advice-add 'org-todo-list :before #'vulpea-agenda-files-update) diff --git a/custom.el b/custom.el new file mode 100644 index 0000000..fd3b743 --- /dev/null +++ b/custom.el @@ -0,0 +1,13 @@ +(custom-set-variables + ;; custom-set-variables was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right. + '(package-selected-packages + '(catppuccin-theme obsidian olivetti org-download org-superstar vulpea))) +(custom-set-faces + ;; custom-set-faces was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right. + ) diff --git a/init.el b/init.el new file mode 100644 index 0000000..63a14d4 --- /dev/null +++ b/init.el @@ -0,0 +1,194 @@ +;;; init.el -*- lexical-binding: t; -*- + +;; This file controls what Doom modules are enabled and what order they load +;; in. Remember to run 'doom sync' after modifying it! + +;; NOTE Press 'SPC h d h' (or 'C-h d h' for non-vim users) to access Doom's +;; documentation. There you'll find a link to Doom's Module Index where all +;; of our modules are listed, including what flags they support. + +;; NOTE Move your cursor over a module's name (or its flags) and press 'K' (or +;; 'C-c c k' for non-vim users) to view its documentation. This works on +;; flags as well (those symbols that start with a plus). +;; +;; Alternatively, press 'gd' (or 'C-c c d') on a module to browse its +;; directory (for easy access to its source code). + +(doom! :input + ;;bidi ; (tfel ot) thgir etirw uoy gnipleh + ;;chinese + ;;japanese + ;;layout ; auie,ctsrnm is the superior home row + + :completion + company ; the ultimate code completion backend + ;;(corfu +orderless) ; complete with cap(f), cape and a flying feather! + ;;helm ; the *other* search engine for love and life + ;;ido ; the other *other* search engine... + ;;ivy ; a search engine for love and life + vertico ; the search engine of the future + + :ui + ;;deft ; notational velocity for Emacs + doom ; what makes DOOM look the way it does + doom-dashboard ; a nifty splash screen for Emacs + ;;doom-quit ; DOOM quit-message prompts when you quit Emacs + (emoji +unicode) ; 🙂 + hl-todo ; highlight TODO/FIXME/NOTE/DEPRECATED/HACK/REVIEW + ;;indent-guides ; highlighted indent columns + ligatures ; ligatures and symbols to make your code pretty again + minimap ; show a map of the code on the side + modeline ; snazzy, Atom-inspired modeline, plus API + ;;nav-flash ; blink cursor line after big motions + ;;neotree ; a project drawer, like NERDTree for vim + ophints ; highlight the region an operation acts on + (popup +defaults) ; tame sudden yet inevitable temporary windows + ;;tabs ; a tab bar for Emacs + treemacs ; a project drawer, like neotree but cooler + unicode ; extended unicode support for various languages + (vc-gutter +pretty) ; vcs diff in the fringe + vi-tilde-fringe ; fringe tildes to mark beyond EOB + window-select ; visually switch windows + workspaces ; tab emulation, persistence & separate workspaces + ;;zen ; distraction-free coding or writing + + :editor + ;;(evil +everywhere); come to the dark side, we have cookies + file-templates ; auto-snippets for empty files + fold ; (nigh) universal code folding + (format +onsave) ; automated prettiness + ;;god ; run Emacs commands without modifier keys + ;;lispy ; vim for lisp, for people who don't like vim + multiple-cursors ; editing in many places at once + ;;objed ; text object editing for the innocent + ;;parinfer ; turn lisp into python, sort of + ;;rotate-text ; cycle region at point between text candidates + snippets ; my elves. They type so I don't have to + ;;word-wrap ; soft wrapping with language-aware indent + + :emacs + dired ; making dired pretty [functional] + electric ; smarter, keyword-based electric-indent + ;;eww ; the internet is gross + ibuffer ; interactive buffer management + undo ; persistent, smarter undo for your inevitable mistakes + vc ; version-control and Emacs, sitting in a tree + + :term + ;;eshell ; the elisp shell that works everywhere + ;;shell ; simple shell REPL for Emacs + ;;term ; basic terminal emulator for Emacs + vterm ; the best terminal emulation in Emacs + + :checkers + syntax ; tasing you for every semicolon you forget + (spell +flyspell) ; tasing you for misspelling mispelling + grammar ; tasing grammar mistake every you make + + :tools + ;;ansible + ;;biblio ; Writes a PhD for you (citation needed) + ;;collab ; buffers with friends + debugger ; FIXME stepping through code, to help you add bugs + direnv + docker + ;;editorconfig ; let someone else argue about tabs vs spaces + ;;ein ; tame Jupyter notebooks with emacs + (eval +overlay) ; run code, run (also, repls) + lookup ; navigate your code and its documentation + lsp ; M-x vscode + magit ; a git porcelain for Emacs + make ; run make tasks from Emacs + ;;pass ; password manager for nerds + pdf ; pdf enhancements + ;;prodigy ; FIXME managing external services & code builders + ;;terraform ; infrastructure as code + ;;tmux ; an API for interacting with tmux + ;;tree-sitter ; syntax and parsing, sitting in a tree... + ;;upload ; map local to remote projects via ssh/ftp + + :os + (:if (featurep :system 'macos) macos) ; improve compatibility with macOS + ;;tty ; improve the terminal Emacs experience + + :lang + ;;agda ; types of types of types of types... + ;;beancount ; mind the GAAP + (cc +lsp) ; C > C++ == 1 + ;;clojure ; java with a lisp + ;;common-lisp ; if you've seen one lisp, you've seen them all + coq ; proofs-as-programs + ;;crystal ; ruby at the speed of c + ;;csharp ; unity, .NET, and mono shenanigans + data ; config/data formats + ;;(dart +flutter) ; paint ui and not much else + ;;dhall + ;;elixir ; erlang done right + ;;elm ; care for a cup of TEA? + emacs-lisp ; drown in parentheses + ;;erlang ; an elegant language for a more civilized age + ;;ess ; emacs speaks statistics + ;;factor + ;;faust ; dsp, but you get to keep your soul + ;;fortran ; in FORTRAN, GOD is REAL (unless declared INTEGER) + ;;fsharp ; ML stands for Microsoft's Language + ;;fstar ; (dependent) types and (monadic) effects and Z3 + ;;gdscript ; the language you waited for + ;;(go +lsp) ; the hipster dialect + ;;(graphql +lsp) ; Give queries a REST + ;;(haskell +lsp) ; a language that's lazier than I am + ;;hy ; readability of scheme w/ speed of python + ;;idris ; a language you can depend on + json ; At least it ain't XML + (java +lsp) ; the poster child for carpal tunnel syndrome + ;;javascript ; all(hope(abandon(ye(who(enter(here)))))) + ;;julia ; a better, faster MATLAB + ;;kotlin ; a better, slicker Java(Script) + ;;latex ; writing papers in Emacs has never been so fun + ;;lean ; for folks with too much to prove + ;;ledger ; be audit you can be + ;;lua ; one-based indices? one-based indices + markdown ; writing docs for people to ignore + ;;nim ; python + lisp at the speed of c + nix ; I hereby declare "nix geht mehr!" + ;;ocaml ; an objective camel + (org +roam2) ; organize your plain life in plain text + ;;php ; perl's insecure younger brother + ;;plantuml ; diagrams for confusing people more + ;;graphviz ; diagrams for confusing yourself even more + ;;purescript ; javascript, but functional + python ; beautiful is better than ugly + ;;qt ; the 'cutest' gui framework ever + ;;racket ; a DSL for DSLs + ;;raku ; the artist formerly known as perl6 + ;;rest ; Emacs as a REST client + ;;rst ; ReST in peace + ;;(ruby +rails) ; 1.step {|i| p "Ruby is #{i.even? ? 'love' : 'life'}"} + (rust +lsp) ; Fe2O3.unwrap().unwrap().unwrap().unwrap() + ;;scala ; java, but good + ;;(scheme +guile) ; a fully conniving family of lisps + sh ; she sells {ba,z,fi}sh shells on the C xor + ;;sml + ;;solidity ; do you need a blockchain? No. + ;;swift ; who asked for emoji variables? + ;;terra ; Earth and Moon in alignment for performance. + ;;web ; the tubes + yaml ; JSON, but readable + ;;zig ; C, but simpler + + :email + ;;(mu4e +org +gmail) + ;;notmuch + ;;(wanderlust +gmail) + + :app + ;;calendar + ;;emms + ;;everywhere ; *leave* Emacs!? You must be joking + ;;irc ; how neckbeards socialize + ;;(rss +org) ; emacs as an RSS reader + + :config + ;;literate + (default +bindings +smartparens)) + diff --git a/org-phscroll.el b/org-phscroll.el new file mode 100644 index 0000000..a0bfa65 --- /dev/null +++ b/org-phscroll.el @@ -0,0 +1,352 @@ +;;; org-phscroll.el --- Apply horizontal scroll to org-mode table -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 AKIYAMA Kouhei + +;; Author: AKIYAMA Kouhei +;; Keywords: + +;; 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: + +;;; Enable wide table horizontal scrolling even if org-startup-truncated is nil. + +;;; Usage: + +;;; (load "org-phscroll.el") + +;;; Code: + +(require 'org) +(require 'phscroll) + +(defvar org-phscroll-buffer-name-regexp-to-disable + '(;; see: org-src-font-lock-fontify-block in org-src.el + "\\` *\\*org-src-fontification:.*\\*\\'" + ;; see: org-html-fontify-code in ox-html.el + "\\` *\\*temp\\*-[0-9]+\\'")) + +(defvar-local org-phscroll-disabled nil) +(defvar-local org-phscroll-font-lock-keywords (list '(org-phscroll--fontify))) + +;;;###autoload +(define-minor-mode org-phscroll-mode + "Apply phscroll to org-table." + :type 'boolean + :init-value nil + :group 'org-phscroll + + (if org-phscroll-mode + (progn + ;; Do not anything in some buffers. + (setq-local org-phscroll-disabled + (not + (null + (seq-some + (lambda (regexp) (string-match-p regexp (buffer-name))) + org-phscroll-buffer-name-regexp-to-disable)))) + ;; (when org-phscroll-disabled + ;; (message "Disable org-phscroll-mode in %s" (buffer-name))) + (unless org-phscroll-disabled + ;; Do not update on modification-hooks. Update on font-lock. + (setq-local phscroll-update-area-display-on-modified nil) + (phscroll-mode 1) + (font-lock-add-keywords nil org-phscroll-font-lock-keywords t) + (font-lock-flush))) + (unless org-phscroll-disabled + (font-lock-remove-keywords nil org-phscroll-font-lock-keywords) + (setq-local phscroll-update-area-display-on-modified t) + (phscroll-delete-all) ;;@todo Keep manually added areas (Identify areas created by org-phscroll, and delete(remove-region) only areas created by org-phscroll when fontify) + (phscroll-mode -1)))) + +(defun org-phscroll--fontify (limit) + (when org-phscroll-mode + (save-match-data + (save-excursion + (save-restriction + (widen) + + ;; Invalidate areas that overlaps range to fontify. + ;; Because the text width may have changed due to the + ;; fontify of the previous keyword (for example, the + ;; org-link value of the invisible property). + (phscroll-invalidate-region (point) limit) + + ;; Create/Delete/Move phscroll areas. + (goto-char (phscroll-line-begin)) + (let* ((start (point)) + ;; ("|" or "+-[+-]") ... not whitespace + (table-re "^[ \t]*\\(\\(|\\|\\+-[-+]\\).*\\S-\\)") + ;; [^|+] + ;; +([^-] or $) + ;; +-([^+-] or $) + ;; +-[+-] whitespace...$ + ;; | whitespace...$ + ;; $ + (not-table-re "^[ \t]*\\([^|+ \t]\\|\\+\\([^-]\\|$\\|-\\([^-+]\\|$\\|[-+]\\s-*$\\)\\)\\||\\s-*$\\|$\\)") + (phscroll-fontify-range (cons start limit)) + not-table-beg) + ;;(message "org-phscroll--fontify start=%s limit=%s line-end=%s" start limit (phscroll-line-end));;debug + + (while (progn + (setq not-table-beg (point)) + (and (< (point) limit) + (re-search-forward table-re limit t))) + + (let* ((not-table-end (phscroll-line-begin)) + (table-beg not-table-end) + (table-end (if (re-search-forward not-table-re limit t) + (goto-char (phscroll-line-begin (match-beginning 0))) ;; beginning of not table + (goto-char limit)))) ;; end of fontify + ;; not table + (if (< not-table-beg not-table-end) + (phscroll-remove-region not-table-beg not-table-end)) + + ;; table? + ;; exclude comment, blocks + (if (or (text-property-any table-beg table-end 'face 'org-table) + (eq (car-safe (get-text-property table-beg 'face)) 'org-table)) ;; for org-modern (org-table (:overline) (:height 0.1)) + ;; table + (progn + ;; include previous line if previous line is in area + (if (and (= start table-beg) + (phscroll-enum-area (phscroll-line-begin (1- start)) + (phscroll-line-end (1- start)))) + (setq table-beg (phscroll-line-begin (1- start)))) + ;; include next line if next line is in area + (if (phscroll-enum-area (phscroll-line-begin table-end) + (phscroll-line-end table-end)) + (setq table-end (min (point-max) + (1+ (phscroll-line-end table-end))))) + ;; cover single area + (phscroll-cover-region table-beg table-end)) + ;; not table + (phscroll-remove-region table-beg table-end)))) + + ;; not table + (if (< not-table-beg limit) + (phscroll-remove-region not-table-beg limit)))))) + nil)) + +;; (defun org-phscroll--font-lock-set-keywords () +;; ;; See: org-set-font-lock-defaults +;; (nconc +;; org-font-lock-extra-keywords +;; (list +;; '(org-phscroll--fontify)))) + + +;;;; Support for table column shrink/expand + +(defun org-phscroll-invalidate-table (pos) + (when-let ((area (phscroll-get-area-at pos))) + (phscroll-area-clear-updated-ranges area) + ;; @todo necessary? + ;; (font-lock-unfontify-region + ;; (phscroll-area-begin area) + ;; (phscroll-area-end area)) + )) + +(defun org-phscroll--table-shrink-columns (_columns beg _end &rest _) + (org-phscroll-invalidate-table beg)) + +(defun org-phscroll--table-expand (&optional beg _end &rest _) + (when (and (null beg) + (org-at-table-p)) + (setq beg (org-table-begin))) + + (when beg + (org-phscroll-invalidate-table beg))) + +;;;; Support for org-table-overlay-coordinates + +(defun org-phscroll--table-toggle-coordinate-overlays (&rest _) + (org-phscroll-invalidate-table (point))) + +;;;; Support for org-table-header-line-mode + +(defun org-phscroll--after-table-header-line-mode (&rest _) + ;; Cancel post-command-hook. + ;; Use phscroll's post-command-hook only. + (remove-hook 'post-command-hook #'org-table-header-set-header t)) + +(defun org-phscroll--table-row-get-visible-string (old-func &optional beg) + (unless beg + (setq beg (point))) + (let ((area (phscroll-get-area-at beg))) + (if (null area) + ;; Call original + (funcall old-func beg) + ;; In phscroll area + (save-excursion + + ;;@todo Is it possible to unify with around phscroll-char-width-next? + ;;@todo Support more properties + (let ((pos (phscroll-line-begin beg)) + (eol (phscroll-line-end beg)) + visible-strs) + + (while (< pos eol) + (let (next-pos pvalue) + ;; Overlay + (let ((overlays (overlays-at pos t))) + (while (and overlays (null next-pos)) + (let ((ov (car overlays))) + (unless (or (overlay-get ov 'phscroll) + (overlay-get ov 'phscroll-ignore)) + (cond + ;; Overlay's display + ((setq pvalue (overlay-get ov 'display)) + (when (stringp pvalue) + (push pvalue visible-strs)) + (setq next-pos (overlay-end ov))) + ;; Overlay's invisible + ((and (setq pvalue (overlay-get ov 'invisible)) + (invisible-p pvalue)) + (setq next-pos (overlay-end ov)))))) + (setq overlays (cdr overlays)))) + ;; Text property + (unless next-pos + (cond + ;; Text's display + ((setq pvalue (get-text-property pos 'display)) + (cond + ((stringp pvalue) + (push pvalue visible-strs)) + ((and (consp pvalue) + (eq (car pvalue) 'space) + (eq (cadr pvalue) :relative-width) + (integerp (caddr pvalue))) + (push (make-string (caddr pvalue) (char-after pos)) visible-strs))) + (setq next-pos + (next-single-property-change pos 'display nil eol))) + ;; Text's invisible + ((and (setq pvalue (get-text-property pos 'invisible)) + (invisible-p pvalue)) + (setq next-pos + (next-single-property-change pos 'invisible nil eol))) + ;; Character + (t + (push (char-to-string (char-after pos)) visible-strs) + (setq next-pos (1+ pos))))) + (setq pos next-pos))) + + (let* ((win-width (phscroll-window-width-at beg nil)) + (scroll-column (phscroll-get-scroll-column area)) + (visible-str (apply #'concat (nreverse visible-strs))) + (result (truncate-string-to-width + visible-str + (+ scroll-column win-width) + scroll-column ?\s))) + ;;(message "result=%s" result) + result)))))) + +(defun org-phscroll--around-post-command-in-header-line-mode (old-func &rest args) + (if (and (boundp 'org-table-header-line-mode) ;; Org 9.4 or later + org-table-header-line-mode) + (progn + ;; Delete overlay before phscroll process + (when (overlayp org-table-header-overlay) + (delete-overlay org-table-header-overlay) + (setq org-table-header-overlay nil)) + ;; Call phscroll process + (prog1 (apply old-func args) + ;; Update header line + (ignore-errors + (org-table-header-set-header)) + (when org-table-header-overlay + (overlay-put org-table-header-overlay 'phscroll-ignore t) + (overlay-put org-table-header-overlay 'priority 20) + (let ((win-start (overlay-start org-table-header-overlay))) + (move-overlay org-table-header-overlay + (phscroll-line-begin win-start) + (phscroll-line-end win-start)))))) + ;; Not in header line mode + (apply old-func args))) + +;;;; Support for org-indent + +(defun org-phscroll-invalidate-indent (beg end) + ;;(message "invalidate %s %s" beg end) + (dolist (area (phscroll-enum-area beg end)) + (phscroll-area-remove-updated-range beg end area) + ;;(phscroll-area-clear-updated-ranges area) + )) + +(defun org-phscroll--indent-add-properties (beg end &optional _delay) + (org-phscroll-invalidate-indent beg end)) + +;;;; Hook global functions + +;;;###autoload +(defun org-phscroll-activate () + (interactive) + (add-hook 'org-mode-hook + #'org-phscroll-mode) + ;; (add-hook 'org-font-lock-set-keywords-hook + ;; #'org-phscroll--font-lock-set-keywords) + ;; for table shrink/expand + (advice-add #'org-table--shrink-columns + :after #'org-phscroll--table-shrink-columns) + (advice-add #'org-table-expand + :after #'org-phscroll--table-expand) + ;; for org-table-overlay-coordinates + (advice-add #'org-table-toggle-coordinate-overlays + :after #'org-phscroll--table-toggle-coordinate-overlays) + ;; for org-table-header-line-mode + (advice-add #'org-table-header-line-mode + :after #'org-phscroll--after-table-header-line-mode) + (advice-add #'org-table-row-get-visible-string + :around #'org-phscroll--table-row-get-visible-string) + (advice-add #'phscroll-on-post-command + :around #'org-phscroll--around-post-command-in-header-line-mode) + ;; for indent + (with-no-warnings ;;Some one not needs to (require 'org-indent) + (advice-add #'org-indent-add-properties + :after #'org-phscroll--indent-add-properties))) + +;;;###autoload +(defun org-phscroll-deactivate () + (interactive) + (remove-hook 'org-mode-hook + #'org-phscroll-mode) + ;; (remove-hook 'org-font-lock-set-keywords-hook + ;; #'org-phscroll--font-lock-set-keywords) + ;; for table shrink/expand + (advice-remove #'org-table--shrink-columns + #'org-phscroll--table-shrink-columns) + (advice-remove #'org-table-expand + #'org-phscroll--table-expand) + ;; for org-table-overlay-coordinates + (advice-remove #'org-table-toggle-coordinate-overlays + #'org-phscroll--table-toggle-coordinate-overlays) + ;; for org-table-header-line-mode + (advice-remove #'org-table-header-line-mode + #'org-phscroll--after-table-header-line-mode) + (advice-remove #'org-table-row-get-visible-string + #'org-phscroll--table-row-get-visible-string) + (advice-remove #'phscroll-on-post-command + #'org-phscroll--around-post-command-in-header-line-mode) + ;; for indent + (with-no-warnings ;;Some one not needs to (require 'org-indent) + (advice-remove #'org-indent-add-properties + #'org-phscroll--indent-add-properties))) + + +(with-eval-after-load "org" + (org-phscroll-activate)) + + +(provide 'org-phscroll) +;;; org-phscroll.el ends here diff --git a/packages.el b/packages.el new file mode 100644 index 0000000..d3511da --- /dev/null +++ b/packages.el @@ -0,0 +1,57 @@ +;; -*- no-byte-compile: t; -*- +;;; $DOOMDIR/packages.el + +;; To install a package with Doom you must declare them here and run 'doom sync' +;; on the command line, then restart Emacs for the changes to take effect -- or + + +;; To install SOME-PACKAGE from MELPA, ELPA or emacsmirror: +;; (package! some-package) + +;; To install a package directly from a remote git repo, you must specify a +;; `:recipe'. You'll find documentation on what `:recipe' accepts here: +;; https://github.com/radian-software/straight.el#the-recipe-format +;; (package! another-package +;; :recipe (:host github :repo "username/repo")) + +;; If the package you are trying to install does not contain a PACKAGENAME.el +;; file, or is located in a subdirectory of the repo, you'll need to specify +;; `:files' in the `:recipe': +;; (package! this-package +;; :recipe (:host github :repo "username/repo" +;; :files ("some-file.el" "src/lisp/*.el"))) + +;; If you'd like to disable a package included with Doom, you can do so here +;; with the `:disable' property: +;; (package! builtin-package :disable t) + +;; You can override the recipe of a built in package without having to specify +;; all the properties for `:recipe'. These will inherit the rest of its recipe +;; from Doom or MELPA/ELPA/Emacsmirror: +;; (package! builtin-package :recipe (:nonrecursive t)) +;; (package! builtin-package-2 :recipe (:repo "myfork/package")) + +;; Specify a `:branch' to install a package from a particular branch or tag. +;; This is required for some packages whose default branch isn't 'master' (which +;; our package manager can't deal with; see radian-software/straight.el#279) +;; (package! builtin-package :recipe (:branch "develop")) + +;; Use `:pin' to specify a particular commit to install. +;; (package! builtin-package :pin "1a2b3c4d5e") + + +;; Doom's packages are pinned to a specific commit and updated from release to +;; release. The `unpin!' macro allows you to unpin single packages... +;; (unpin! pinned-package) +;; ...or multiple packages +;; (unpin! pinned-package another-pinned-package) +;; ...Or *all* packages (NOT RECOMMENDED; will likely break things) +;; (unpin! t) +(package! copilot + :recipe (:host github :repo "copilot-emacs/copilot.el" :files ("*.el"))) + +(package! org-appear + :recipe (:type git :host github :repo "awth13/org-appear")) + +(package! org-modern + :recipe (:type git :host github :repo "minad/org-modern")) diff --git a/phscroll.el b/phscroll.el new file mode 100644 index 0000000..d83a821 --- /dev/null +++ b/phscroll.el @@ -0,0 +1,1426 @@ +;;; phscroll.el --- Partial horizontal scroll -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 AKIYAMA Kouhei + +;; Author: AKIYAMA Kouhei +;; Keywords: + +;; 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: + +;;; Usage: + +;;; 1. (require 'phscroll) +;;; 2. Select region you want to hscroll. +;;; 3. M-x phscroll-region + +;;; Code: + +(require 'cl-lib) +(require 'subr-x) + +;; TODO: +;; - [X] truncate-lines によって動作を変える。truncate-linesのときは何もしない。切り替えを検出できるか +;; - [X] remove-overlaysのところ +;; - phscroll-update-area-displayが遅い +;; - [X] 既存の水平スクロール操作に対応?(scroll-left, scroll-right) +;; - [X] 複数ウィンドウの挙動、特に左右に分割した場合で左右のサイズが異なる場合はどうしようもない。最小幅を使うしか？　何もしない方が良い？ →area毎に幅を持って変化をチェックする。 + +;;;; Customization + +(defgroup phscroll nil + "Creates horizontally scrolling areas in a buffer." + :prefix "phscroll-" + :group 'convenience) + +(defcustom phscroll-use-fringe t + "Specifies how to indicate the possibility of scrolling left or right. +Use fringe when non-nil. +If it is nil, it is indicated by the < and > characters." + :type 'boolean + :group 'phscroll) + +(defvar phscroll-margin-right-additional 0) ;;for stability + +(defun phscroll-margin-right () + (+ phscroll-margin-right-additional + (if phscroll-use-fringe 1 2))) + +(defcustom phscroll-scroll-left-right-move-point t + "If non-nil, move point with left/right scroll commands." + :type 'boolean + :group 'phscroll) + +(defcustom phscroll-scroll-left-right-reverse-direction nil + "If non-nil, reverse direction of left/right scroll command." + :type 'boolean + :group 'phscroll) + +(defcustom phscroll-calculate-in-pixels nil + "Experimental." + :type 'boolean + :group 'phscroll) + +;;;; Basic Commands + +(defvar-local phscroll-truncate-lines nil) ;; to detect truncate-lines change + +(define-minor-mode phscroll-mode + + "Partial horizontal scroll mode." + :global nil + (cond + (phscroll-mode + (setq-local phscroll-truncate-lines truncate-lines) + (add-hook 'post-command-hook #'phscroll-on-post-command nil t) + (add-hook 'window-scroll-functions #'phscroll-on-window-scroll nil t) + ;;(add-hook 'window-size-change-functions #'phscroll-on-window-size-changed nil t) + (add-hook 'pre-redisplay-functions #'phscroll-on-pre-redisplay nil t) + ) + (t + (remove-hook 'post-command-hook #'phscroll-on-post-command t) + (remove-hook 'window-scroll-functions #'phscroll-on-window-scroll t) + ;;(remove-hook 'window-size-change-functions #'phscroll-on-window-size-changed t) + (remove-hook 'pre-redisplay-functions #'phscroll-on-pre-redisplay t) + ))) + +(defun phscroll-region (beg end) + "Make a partial horizontal scrolling area. + +The area to be created has a range from the line containing BEG +to the line containing END (however, if END is the beginning of +the line, that line is not included). + +Any existing overlapping areas are destroyed." + (interactive "r") + (setq beg (phscroll-line-begin beg)) + (setq end (if (save-excursion (goto-char end) (bolp)) + end + (phscroll-line-end end))) + + (when (< beg end) + ;; turn on phscroll-mode + (unless phscroll-mode + (phscroll-mode)) + + ;; create overlay and area object + (let* ((overlap-areas (phscroll-enum-area beg end)) + (area (car overlap-areas))) + (if area + ;; reuse area + (progn + ;; reuse area + (phscroll-area-move area beg end) + (phscroll-update-area-display area) + ;; destroy other overlap areas + (cl-loop for ooa in (cdr overlap-areas) + do (phscroll-area-destroy ooa))) + ;; create new area + (setq area (phscroll-area-create beg end)) + (phscroll-update-area-display area t)) + area))) + +(defun phscroll-delete-at (&optional pos) + "Delete the area at POS." + (interactive "d") + (phscroll-area-destroy (phscroll-get-area-at pos))) + +(defun phscroll-delete-all () + "Destroy all areas in the current buffer." + (interactive) + (cl-loop for area in (phscroll-enum-area) + do (phscroll-area-destroy area))) + +(defun phscroll-update-at (&optional pos) + "Redisplay the area at POS." + (interactive "d") + (phscroll-update-area-display (phscroll-get-area-at pos) t)) + +(defun phscroll-merge-region (beg end &optional no-update) + "Merge all areas that overlap the region BEG..END. + +If NO-UPDATE is non-nil, this function will not call +`phscroll-update-area-display'." + (interactive "r") + (let* ((areas (sort (phscroll-enum-area beg end) + (lambda (a1 a2) + (< (phscroll-area-begin a1) (phscroll-area-begin a2))))) + (result (car areas))) + (setq areas (cdr areas)) + (while areas + (phscroll-area-merge result (car areas)) + (setq areas (cdr areas))) + (when (and result (not no-update)) + (phscroll-update-area-display result)) + result)) + +(defun phscroll-cover-region (beg end) + "Cover the region BEG..END with a single phscroll area." + (interactive "r") + + (if-let ((area (phscroll-merge-region beg end t)));;no-update=t + (let ((area-beg (phscroll-area-begin area)) + (area-end (phscroll-area-end area))) + (when (or (< beg area-beg) (< area-end end)) + (phscroll-area-move area + (min beg area-beg) + (max end area-end))) + (phscroll-update-area-display area) + area) + (phscroll-region beg end))) + +(defun phscroll-remove-region (beg end) + "Remove phscroll areas from the region BEG..END. + +Areas that overlap the region will be deleted, moved, or splitted." + (interactive "r") + + (dolist (area (phscroll-enum-area beg end)) + (let ((area-beg (phscroll-area-begin area)) + (area-end (phscroll-area-end area))) + (cond + ;; keep area + ((<= area-end beg) nil) + ((<= end area-beg) nil) + ;; delete area + ((and (<= beg area-beg) (<= area-end end)) + (phscroll-area-destroy area)) + ;; split area + ((and (< area-beg beg) (< end area-end)) + (phscroll-area-split area end) + (phscroll-area-move area area-beg beg) + (phscroll-update-area-display area);;unnecessary + ) + ;; move area + ((< area-beg beg) + (phscroll-area-move area area-beg beg) + (phscroll-update-area-display area);;unnecessary + ) + ((< end area-end) + (phscroll-area-move area end area-end) + (phscroll-update-area-display area);;unnecessary + ))))) + + + +;;;; Area object + + +(defun phscroll-area-create (beg end &optional evaporate + init-scroll-column + init-updated-ranges + init-window-width) + "Create a new area object covering BEG to END. + +EVAPORATE is the same as the overlay property of the same name. + +INIT-SCROLL-COLUMN, INIT-UPDATED-RANGES, INIT-WINDOW-WIDTH are +for special cases." + ;;(message "create %s %s" beg end) + (let* ((ov (make-overlay beg end)) + (area (list + 'phscroll ;;0 + (or init-scroll-column 0) ;; 1:scroll-column + ov ;; 2:overlay + (append (list (cons -1 -1)) + init-updated-ranges);; 3:updated-ranges + (or init-window-width -1) ;; 4:window-width when last update-area-display + ))) + (overlay-put ov 'phscroll t) + (overlay-put ov 'phscroll-area area) + (overlay-put ov 'modification-hooks (list #'phscroll-on-modified)) + (when evaporate + (overlay-put ov 'evaporate t)) + (phscroll-area-set-keymap area) + area)) + +(defun phscroll-area-destroy (area) + "Destroy AREA, an area object." + (when area + (let ((beg (phscroll-area-begin area)) + (end (phscroll-area-end area)) + (ov (phscroll-area-overlay area))) + (remove-overlays beg end 'phscroll-left t) + (remove-overlays beg end 'phscroll-right t) + (delete-overlay ov)))) + + +(defun phscroll-area-move (area beg end &optional update) + "Set the endpoints of AREA to BEG and END. + +Call `phscroll-update-area-display' if UPDATE is non-nil. + +Return AREA." + (when (and area (<= beg end)) + (let* ((ov (phscroll-area-overlay area)) + (old-beg (overlay-start ov)) + (old-end (overlay-end ov))) + ;; If area range changed + (when (or (/= old-beg beg) + (/= old-end end)) + ;; Remove ranges outside the new area from updated ranges list + ;; and remove left and right overlays + (if (or (<= old-end beg) (<= end old-beg)) + ;; If there is no overlap between old and new, simply remove old + (progn + (phscroll-area-clear-updated-ranges area) + (remove-overlays old-beg old-end 'phscroll-left t) + (remove-overlays old-beg old-end 'phscroll-right t)) + ;; If overlap, remove protruding part + (when (< old-beg beg) + (phscroll-area-remove-updated-range old-beg beg area) + (remove-overlays old-beg beg 'phscroll-left t) + (remove-overlays old-beg beg 'phscroll-right t)) + (when (< end old-end) + (phscroll-area-remove-updated-range end old-end area) + (remove-overlays end old-end 'phscroll-left t) + (remove-overlays end old-end 'phscroll-right t))) + ;; Shift relative positions in updated ranges list + (when (/= old-beg beg) + (phscroll-area-shift-updated-ranges-after old-beg (- old-beg beg) + area)) + + ;; Move overlay + (move-overlay ov beg end) + + ;; Update new area range + (when update + (phscroll-update-area-display area))))) + area) + +(defun phscroll-area-merge (to-area from-area &optional update) + "Merge FROM-AREA to TO-AREA. + +Call `phscroll-update-area-display' if UPDATE is non-nil. + +Return TO-AREA." + (when (and to-area from-area) + (let* ((to-ov (phscroll-area-overlay to-area)) + (to-beg (overlay-start to-ov)) + (to-end (overlay-end to-ov)) + (from-ov (phscroll-area-overlay from-area)) + (from-beg (overlay-start from-ov)) + (from-end (overlay-end from-ov)) + (overlap-beg (max to-beg from-beg)) + (overlap-end (min to-end from-end)) + (new-beg (min to-beg from-beg)) + (new-end (max to-end from-end))) + + (if (/= (phscroll-area-get-window-width to-area) + (phscroll-area-get-window-width from-area)) + (progn + (phscroll-area-move to-area new-beg new-end) + (move-overlay from-ov new-end new-end) + (delete-overlay from-ov)) + ;; same window width + + ;; Remove updated-ranges in overlapping area from to-area and from-area. + ;; If overlap, they may be broken. + (when (< overlap-beg overlap-end) + (phscroll-area-remove-updated-range overlap-beg overlap-end to-area) + (phscroll-area-remove-updated-range overlap-beg overlap-end from-area)) + + ;; Shift relative positions in updated-ranges + (phscroll-area-shift-updated-ranges-after to-beg (- to-beg new-beg) to-area) + (phscroll-area-shift-updated-ranges-after from-beg (- from-beg new-beg) from-area) + + ;; Concat updated-ranges list + (phscroll-area-updated-ranges-set + to-area + (let* ((lower-ranges (phscroll-area-updated-ranges-get + (if (< to-beg from-beg) to-area from-area))) + (upper-ranges (phscroll-area-updated-ranges-get + (if (< to-beg from-beg) from-area to-area))) + (last-lower (car (last lower-ranges))) + (first-upper (car upper-ranges))) + + ;; Merge last of lower ranges and first of upper ranges + ;;..(last-beg . last-end=first-beg)(last-end=first-beg . first-end).. + ;;..(last-beg . first-end).. + (when (and last-lower + first-upper + (= (cdr last-lower) (car first-upper))) + (setcdr last-lower (cdr first-upper)) + (setq upper-ranges (cdr upper-ranges))) + + ;; Concat list + (nconc lower-ranges upper-ranges))) + + ;; Move overlay + (move-overlay to-ov new-beg new-end) + (move-overlay from-ov new-end new-end) + + ;; Delete from-ov + (delete-overlay from-ov))) + (when update + (phscroll-update-area-display to-area))) + to-area) + +(defun phscroll-area-split (area pos) + "Split AREA at POS. + +AREA will be the first half of the divided area. + +Return a new area that is the second half of the divided area." + (when area + (let* ((area-ov (phscroll-area-overlay area)) + (area-beg (overlay-start area-ov)) + (area-end (overlay-end area-ov))) + (when (and (< area-beg pos) (< pos area-end)) + + (let ((prev-r (phscroll-area-updated-ranges-head area)) + (rel-pos (- pos area-beg)) + new-updated-ranges) + ;; Find first range r.end > pos + (while (and (cdr prev-r) (<= (cdadr prev-r) rel-pos)) + (setq prev-r (cdr prev-r))) + ;; If r.beg < pos, split r + (if (< (caadr prev-r) rel-pos) + (progn + (setq new-updated-ranges + (cons + (cons rel-pos (cdadr prev-r)) + (cddr prev-r))) + (setf (cdadr prev-r) rel-pos) + (setf (cddr prev-r) nil)) + ;; pos <= r.beg and r.end + (setq new-updated-ranges (cdr prev-r)) + (setcdr prev-r nil)) + ;; Move overlay first half + (move-overlay area-ov area-beg pos) + + ;; Create a area second half + (let ((new-area (phscroll-area-create + pos area-end + (overlay-get area-ov 'evaporate) + (phscroll-get-scroll-column area) + new-updated-ranges + (phscroll-area-get-window-width area)))) + ;; Shift updated ranges + (phscroll-area-shift-updated-ranges-after pos (- area-beg pos) new-area) + new-area)))))) + +;; Area Scroll Position + +(defconst phscroll-interactive-scroll-commands + '(phscroll-set-scroll-column + phscroll-scroll-left + phscroll-scroll-right + phscroll-recenter + phscroll-recenter-left-right + phscroll-mwheel-scroll-left + phscroll-mwheel-scroll-right)) + +(defun phscroll-get-scroll-column (&optional area) + (nth 1 (or area (phscroll-get-current-area)))) + +(defun phscroll-set-scroll-column (pos &optional area) + (interactive "nColumn: ") + (when (null area) + (setq area (phscroll-get-current-area))) + (when (< pos 0) + (setq pos 0)) + (when (and area (not (= (phscroll-get-scroll-column area) pos))) + (setcar (nthcdr 1 area) pos) + (phscroll-update-area-display area t))) + +(defun phscroll-add-scroll-column (delta &optional area) + (when (null area) + (setq area (phscroll-get-current-area))) + (when area + (phscroll-set-scroll-column + (+ (phscroll-get-scroll-column area) delta) + area))) + +(defun phscroll-scroll-left (&optional arg area) + (interactive "P") + (phscroll-scroll-left-right-internal + (if arg (prefix-numeric-value arg) (phscroll-scroll-left-right-unit)) + area)) + +(defun phscroll-scroll-right (&optional arg area) + (interactive "P") + (phscroll-scroll-left-right-internal + (- (if arg (prefix-numeric-value arg) (phscroll-scroll-left-right-unit))) + area)) + +(defun phscroll-scroll-left-right-unit () + (max 1 + (- (phscroll-window-width-at (point) nil) + (phscroll-margin-right) + 4))) + +(defun phscroll-scroll-left-right-internal (delta area) + (when phscroll-scroll-left-right-reverse-direction + (setq delta (- delta))) + (when (null area) + (setq area (phscroll-get-current-area))) + + (when area + (when (and phscroll-scroll-left-right-move-point + (<= (phscroll-area-begin area) (point)) + (< (point) (phscroll-area-end area))) + (cond + ((> delta 0) + (goto-char + (+ (phscroll-line-begin) + (phscroll-string-length + (car (phscroll-substring-over-width + (phscroll-current-line-string) + (+ (phscroll-column (point)) + delta))))))) + ((< delta 0) + (goto-char + (+ (phscroll-line-begin) + (phscroll-string-length + (car (phscroll-substring-over-width + (phscroll-current-line-string) + (max 0 (+ (phscroll-column (point)) delta))))))))))) + + (phscroll-add-scroll-column delta area)) + +(defun phscroll-column (pos) + (phscroll-string-width + (phscroll-buffer-substring + (phscroll-line-begin pos) pos))) + +(defun phscroll-show-point (pos) + (let ((area (phscroll-get-area-at pos))) + (when area + (let ((scroll-column (phscroll-get-scroll-column area)) + (pos-column (phscroll-column pos)) + (window-width (phscroll-window-width-at pos nil))) + (cond + ((< pos-column scroll-column) + (phscroll-set-scroll-column pos-column area)) + ((> pos-column (+ scroll-column window-width)) + (phscroll-set-scroll-column (- pos-column window-width) area))))))) + +(defun phscroll-scroll-point (pos) + (let ((area (phscroll-get-area-at pos))) + (when area + (let ((scroll-column (phscroll-get-scroll-column area)) + (pos-column (phscroll-column pos)) + (window-width (phscroll-window-width-at pos nil)) + (step (if (= hscroll-step 0) + (/ (1+ (phscroll-window-width-at pos nil)) 2) + hscroll-step))) + (cond + ((< pos-column (+ scroll-column hscroll-margin)) + (phscroll-set-scroll-column (max 0 (- pos-column hscroll-margin step)) area)) + ((> pos-column (+ scroll-column (- window-width hscroll-margin))) + (phscroll-set-scroll-column (+ (- pos-column window-width) hscroll-margin step) area))))))) + +(defun phscroll-recenter (&optional arg) + (interactive "P") + (let* ((pos (point)) + (pos-column (phscroll-column pos)) + (area (phscroll-get-area-at pos))) + (when area + (phscroll-set-scroll-column + (- pos-column + (if arg + (let ((n (prefix-numeric-value arg))) + (if (>= n 0) n (+ (phscroll-window-width-at pos nil) n))) + (/ (phscroll-window-width-at pos nil) 2))) + area)))) + +(defvar phscroll-recenter-last-op nil) +(defcustom phscroll-recenter-positions '(center left right) + "Cycling order for `phscroll-recenter-left-right'. +Like a recenter-top-bottom." + :type '(repeat (choice + (const :tag "Left" left) + (const :tag "Center" center) + (const :tag "Right" right) + (integer :tag "Column number") + (float :tag "Percentage"))) + :group 'phscroll) + +(defun phscroll-recenter-left-right (&optional arg) + ;; The foloweing code was copied and modified from + ;; recenter-top-bottom in window.el + (interactive "P") + (cond + (arg (phscroll-recenter arg)) + (t + (setq phscroll-recenter-last-op + (car (or + (if (eq this-command last-command) + (cdr (member phscroll-recenter-last-op + phscroll-recenter-positions))) + phscroll-recenter-positions))) + (let* ((win-width (phscroll-window-width-at (point) nil)) + (this-scroll-margin + (min (max 0 hscroll-margin) + (truncate (/ win-width 4.0))))) + (cond ((eq phscroll-recenter-last-op 'center) + (phscroll-recenter)) + ((eq phscroll-recenter-last-op 'left) + (phscroll-recenter this-scroll-margin)) + ((eq phscroll-recenter-last-op 'right) + (phscroll-recenter (- -1 this-scroll-margin))) + ((integerp phscroll-recenter-last-op) + (phscroll-recenter phscroll-recenter-last-op)) + ((floatp phscroll-recenter-last-op) + (phscroll-recenter (round (* phscroll-recenter-last-op win-width))))))))) + +(defun phscroll-recenter-top-bottom (&optional _arg) + (interactive "P") + (call-interactively #'recenter-top-bottom) + (phscroll-recenter)) + + +;; Area Overlay + +(defun phscroll-area-overlay (&optional area) + (nth 2 (or area (phscroll-get-current-area)))) + +;; Area Range + +(defun phscroll-area-begin (&optional area) + (overlay-start (phscroll-area-overlay (or area (phscroll-get-current-area))))) + +(defun phscroll-area-end (&optional area) + (overlay-end (phscroll-area-overlay (or area (phscroll-get-current-area))))) + +;; Area Finding + +(defun phscroll-area-from-overlay (ov) + (overlay-get ov 'phscroll-area)) + +(defun phscroll-get-area-at (pos) + (let (area + (overlays (overlays-at pos))) + (while (and overlays + (null (setq area (phscroll-area-from-overlay (car overlays))))) + (setq overlays (cdr overlays))) + area)) + +(defun phscroll-get-current-area () + (phscroll-get-area-at (point))) + +(defun phscroll-enum-area (&optional beg end) + (interactive "r") + + (let* ((overlays (overlays-in (or beg (point-min)) (or end (point-max))))) + (cl-loop for ov in overlays + if (overlay-get ov 'phscroll-area) + collect (overlay-get ov 'phscroll-area)))) + +(defun phscroll-update-all-area () + (save-restriction + (widen) + (cl-loop for area in (phscroll-enum-area) + do (phscroll-update-area-display area t)))) + +(defun phscroll-invalidate-all-area () + (save-restriction + (widen) + (cl-loop for area in (phscroll-enum-area) + do (phscroll-area-clear-updated-ranges area)))) + +(defun phscroll-invalidate-region (beg end) + (dolist (area (phscroll-enum-area beg end)) + (phscroll-area-remove-updated-range beg end area))) + +(defun phscroll-areas-in-window (&optional window) + (phscroll-enum-area + (min (phscroll-window-start window)) + (max (phscroll-window-end window)))) + +(defun phscroll-update-areas-in-window (&optional redraw window) + (cl-loop for area in (phscroll-areas-in-window window) + do (phscroll-update-area-display area redraw window))) + +;;;; Updated Range Management +;; +;; updated-ranges: +;; ((-1 . -1) (beg0 . end0) (beg1 . end1) ... (begN . endN)) + +(defun phscroll-area-updated-ranges-head (area) + (nth 3 area)) + +(defun phscroll-area-updated-ranges-get (area) + (cdr (phscroll-area-updated-ranges-head area))) + +(defun phscroll-area-updated-ranges-set (area ranges) + (when area + (setcdr (nth 3 area) ranges)) + area) + +(defun phscroll-area-clear-updated-ranges (area) + (phscroll-area-updated-ranges-set area nil)) + +(defun phscroll-area-add-updated-range (beg end area) + ;; 1. check and normalize range (beg, end), if empty then exit + (when (and (< beg end) area) + (let ((area-begin (phscroll-area-begin area)) + (area-end (phscroll-area-end area))) + (when (< beg area-begin) (setq beg area-begin)) + (when (> end area-end) (setq end area-end)) + (when (< beg end) + + ;; convert to relative position + (setq beg (- beg area-begin)) + (setq end (- end area-begin)) + + ;;(message "add-updated-range %s %s to area %s" beg end area) + + ;; 2. find first range r1.end [>=] beg + (let ((prev-r1 (phscroll-area-updated-ranges-head area))) + (while (and (cdr prev-r1) (< (cdadr prev-r1) beg)) + (setq prev-r1 (cdr prev-r1))) + + ;; 3. if not found, append to last + (if (null (cdr prev-r1)) + (setcdr prev-r1 (cons (cons beg end) nil)) + ;; 4. if r1.beg [>] end, insert before r1 + (if (< end (caadr prev-r1)) + (setcdr prev-r1 (cons (cons beg end) (cdr prev-r1))) + ;; else, + (let ((prev-r2 prev-r1)) + ;; 5. find last range r2.begin [<=] end + (while (and (cddr prev-r2) (<= (caaddr prev-r2) end)) + (setq prev-r2 (cdr prev-r2))) + + ;; 6. replace r1~r2 to (union r1~r2, beg~end) + (setcdr prev-r1 + (cons + (cons + (min (caadr prev-r1) beg) + (max (cdadr prev-r2) end)) + (cddr prev-r2)))))))))) + area) + +(defun phscroll-area-remove-updated-range (beg end area) + ;; 1. check and normalize range (beg, end), if empty then exit + (when (and (< beg end) area) + (let ((area-begin (phscroll-area-begin area)) + (area-end (phscroll-area-end area))) + (when (< beg area-begin) (setq beg area-begin)) + (when (> end area-end) (setq end area-end)) + (when (< beg end) + + ;; convert to relative position + (setq beg (- beg area-begin)) + (setq end (- end area-begin)) + + ;; 2. find first range r1.end [>] beg + (let ((prev-r1 (phscroll-area-updated-ranges-head area))) + (while (and (cdr prev-r1) (<= (cdadr prev-r1) beg)) + (setq prev-r1 (cdr prev-r1))) + + ;; 3. if not found, do nothing + (if (null (cdr prev-r1)) + nil + ;; 4. if r1.beg [>=] end, do nothing + (if (<= end (caadr prev-r1)) + nil + ;; else, + (let ((prev-r2 prev-r1)) + ;; 5. find last range r2.begin [<] end + (while (and (cddr prev-r2) (< (caaddr prev-r2) end)) + (setq prev-r2 (cdr prev-r2))) + + ;; 6. subtract beg~end from each r1~r2 + (let ((prev-r prev-r1) + (end-prev-r (cdr prev-r2))) + (while (not (eq prev-r end-prev-r)) + (cond + ;; if beg <= r.beg and r.end <= end, remove r from list + ((and (<= beg (caadr prev-r)) (<= (cdadr prev-r) end)) + (if (eq (cdr prev-r) end-prev-r) ;;remove last range + (setq end-prev-r prev-r)) ;;set prev-r to end + (setcdr prev-r (cddr prev-r)) + ;; keep prev-r + ) + ;; set r to (end . r.end) + ((and (<= beg (caadr prev-r)) (< end (cdadr prev-r))) + (setcar (cadr prev-r) end) + (setq prev-r (cdr prev-r))) + ;; set r to (r.beg . beg) + ((and (< (caadr prev-r) beg) (<= (cdadr prev-r) end)) + (setcdr (cadr prev-r) beg) + (setq prev-r (cdr prev-r))) + ;; divide r to (r.beg . beg) [reuse](end . r.end) + ((and (< (caadr prev-r) beg) (< end (cdadr prev-r))) + (setcdr prev-r + (cons (cons (caadr prev-r) beg) + (cdr prev-r))) + (setcar (caddr prev-r) + end) + (setq prev-r (cddr prev-r))))))))))))) + area) + +;; (setq test-area (phscroll-area-create 10 22)) +;; (phscroll-area-add-updated-range 12 14 test-area) +;; (phscroll-area-add-updated-range 16 18 test-area) +;; (phscroll-area-add-updated-range 20 22 test-area) +;; (phscroll-area-add-updated-range 13 16 test-area) +;; (phscroll-area-remove-updated-range 13 21 test-area) +;; (phscroll-area-remove-updated-range 10 22 test-area) + +(defun phscroll-area-needs-update-range (beg end area) + (when (and (< beg end) area) + (let ((area-begin (phscroll-area-begin area)) + (area-end (phscroll-area-end area))) + (when (< beg area-begin) (setq beg area-begin)) + (when (> end area-end) (setq end area-end)) + (when (< beg end) + + ;; convert to relative position + (setq beg (- beg area-begin)) + (setq end (- end area-begin)) + + (not + (cl-find-if + (lambda (range) (and (<= (car range) beg) (<= end (cdr range)))) + (phscroll-area-updated-ranges-head area))))))) + +;;(phscroll-area-needs-update-range 21 23 test-area) + +(defun phscroll-area-shift-updated-ranges-after (pos delta area) + (when (and area (/= delta 0)) + (let ((area-begin (phscroll-area-begin area)) + (r (cdr (phscroll-area-updated-ranges-head area)))) + + ;; convert to relative position + (setq pos (- pos area-begin)) + + (while (and r (< (cdar r) pos)) + (setq r (cdr r))) + (when r + (when (<= pos (caar r)) (setcar (car r) (+ (caar r) delta))) + (when (<= pos (cdar r)) (setcdr (car r) (+ (cdar r) delta))) + (setq r (cdr r)) + (while r + (setcar (car r) (+ (caar r) delta)) + (setcdr (car r) (+ (cdar r) delta)) + (setq r (cdr r)))))) + area) + +;;(phscroll-area-shift-updated-ranges-after 51 10 test-area) + +;; Area outer width + +;; area毎にレイアウト時のウィンドウ幅を記録している。 +;; 複数のウィンドウが異なる幅を持つ場合にarea毎に別々の幅で表示できると便利なので。 +;; 更新時に以前のウィンドウ幅と変わっている場合は、全ての範囲を無効化して再描画する。 +;; 別々のウィンドウに同じareaが表示される場合はレイアウトが乱れる場合もあるがそれは諦める。 + +(defun phscroll-area-get-window-width (area) + (nth 4 area)) + +(defun phscroll-area-set-window-width (area width) + (setcar (nthcdr 4 area) width)) + +(defun phscroll-area-window-width-changed-p (area window) + (let ((new-width (phscroll-window-width window))) ;;;@todo find minimum width of (phscroll-window-width-at line-pos window) ? + (when (not (= new-width (phscroll-area-get-window-width area))) + (phscroll-area-set-window-width area new-width) + t))) + + + +;;;; Event Handlers + + +;; (defun phscroll-on-window-size-changed (&optional _frame) +;; ;;(message "window-size-changed width beg=%s end=%s width=%s" (window-start) (window-end) (window-width)) +;; ;;(phscroll-update-all-area) ;;Too slow +;; ;;(phscroll-update-areas-in-window) ;;Do not use. window-start and window-end are not updated +;; ;; (phscroll-invalidate-all-area) ;;Use phscroll-area-window-width-changed-p +;; ) + +(defun phscroll-on-post-command () + ;(message "on post command window-end=%s" (window-end)) + ;;(phscroll-show-point (point)) + + (unless (cl-find this-command phscroll-interactive-scroll-commands) + (phscroll-scroll-point (point))) + ;;(phscroll-update-area-display (phscroll-get-area-at (point))) + (phscroll-update-areas-in-window nil nil) + ) + +(defun phscroll-on-window-scroll (window _new-display-start-pos) + (phscroll-update-areas-in-window nil window)) + +(defun phscroll-on-pre-redisplay (&optional window) + ;;(message "redisplay window=%s start=%s end=%s width=%s" window (window-start window) (window-end window) (window-width window)) + (phscroll-check-truncate-lines) + (phscroll-update-areas-in-window nil window)) + +(defvar-local phscroll-update-area-display-on-modified t) + +(defun phscroll-on-modified (ov after beg end &optional before-length) + ;;(message "modified %s %s %s %s" after beg end before-length) + (when after + (let* ((after-length (- end beg)) + (delta-length (- after-length before-length)) + (area (phscroll-area-from-overlay ov))) + (when area + (if (= (phscroll-area-begin area) (phscroll-area-end area)) + ;; destroy empty area + (phscroll-area-destroy area) + ;; update modified range + (cond + ((> delta-length 0) + (phscroll-area-shift-updated-ranges-after beg delta-length area) + (phscroll-area-remove-updated-range (phscroll-line-begin beg) (phscroll-line-end end) area)) + + ((< delta-length 0) + (phscroll-area-remove-updated-range (phscroll-line-begin beg) (phscroll-line-end (+ beg before-length)) area) + (phscroll-area-shift-updated-ranges-after end delta-length area)) + + (t + (phscroll-area-remove-updated-range (phscroll-line-begin beg) (phscroll-line-end end) area))) + ;;;@todo do pre-redisplay only? + (when phscroll-update-area-display-on-modified + (phscroll-update-area-display area))))))) + + +(defun phscroll-check-truncate-lines () + (when (not (equal truncate-lines phscroll-truncate-lines)) + (setq phscroll-truncate-lines truncate-lines) + (when phscroll-truncate-lines + ;; remove left, right overlays + (cl-loop for area in (phscroll-enum-area) + do (let ((beg (phscroll-area-begin area)) + (end (phscroll-area-end area))) + (remove-overlays beg end 'phscroll-left t) + (remove-overlays beg end 'phscroll-right t)))) + ;; remove update-ranges and redraw + (phscroll-update-all-area))) + +;; Mouse Wheel + +(defcustom phscroll-mwheel-scroll-amount-horizontal nil + "Amount to scroll phscroll areas horizontally." + :type '(choice (const :tag "Use `mouse-wheel-scroll-amount-horizontal'" nil) + (integer 4)) + :group 'phscroll) + +(defun phscroll-mwheel-scroll-left (event) + (interactive "e") + (phscroll-mwheel-scroll-left-right-internal event 1)) + +(defun phscroll-mwheel-scroll-right (event) + (interactive "e") + (phscroll-mwheel-scroll-left-right-internal event -1)) + +(defun phscroll-mwheel-scroll-left-right-internal (event dir) + (interactive "e") + (when-let ((point (posn-point (event-start event))) + (window (posn-window (event-start event)))) + (with-current-buffer (window-buffer window) + (when-let ((area (phscroll-get-area-at point))) + (phscroll-scroll-right + (* dir + (or phscroll-mwheel-scroll-amount-horizontal + (and (boundp 'mouse-wheel-scroll-amount-horizontal) + mouse-wheel-scroll-amount-horizontal) + 4)) + area))))) + +;; Keymap + +(defvar phscroll-keymap + (let ((map (make-sparse-keymap))) + (define-key map "\C-x<" 'phscroll-scroll-left) + (define-key map "\C-x>" 'phscroll-scroll-right) + (define-key map (kbd "C-S-l") 'phscroll-recenter-left-right) + (define-key map (kbd "C-l") 'phscroll-recenter-top-bottom) + ;; Shift + Mouse Wheel + (when (boundp 'mouse-wheel-down-event) + (define-key map (vector (list 'shift mouse-wheel-down-event)) + 'phscroll-mwheel-scroll-left)) + (when (boundp 'mouse-wheel-up-event) + (define-key map (vector (list 'shift mouse-wheel-up-event)) + 'phscroll-mwheel-scroll-right)) + map)) + +(defun phscroll-area-set-keymap (area) + (when area + (overlay-put (phscroll-area-overlay area) 'keymap phscroll-keymap))) + + + +;;;; Window Utilities + + +(defvar phscroll-use-window-end-update nil) ;;;@todo + +(defun phscroll-window-start (window) + ;;@todo pre-redisplay-functions 内では正しい値を返さない？ + (window-start window)) + +(defun phscroll-window-end (window) + ;;@todo pre-redisplay-functions 内では正しい値を返さない。徐々に増えていく場合がある。 + (max + (or (window-end window phscroll-use-window-end-update) 0) + ;; window-startからwindow行数だけ進んだ場所。 + ;; 不可視の行がある場合は正しくないが、再描画が終わるまで待つよりは良い場合がある。不可視の行を判定すればたどり着けるかもしれないが、テキストプロパティやオーバーレイを取得しながらだとおそらくかなり遅い。 + (save-excursion + (goto-char (window-start window)) + (forward-line (window-body-height window)) + (point)))) + +(defun phscroll-window-width-at (pos window) + (- + (phscroll-window-width window) + ;; Count wrap-prefix width. + ;; org-indent uses this. + (length (get-text-property pos 'wrap-prefix)) + ;; Count before-string width at the beginning of the line. + ;; org-table-overlay-coordinates uses this. + (let ((bol (phscroll-line-begin pos))) + (cl-loop for ov in (overlays-at bol) + sum (length (and (equal (overlay-start ov) bol) + (overlay-get ov 'before-string))))))) + +(defun phscroll-window-width (&optional window) + (max + 0 + (- + (window-body-width window) + (phscroll-margin-right) + ;; line numbers + (if (fboundp 'line-number-display-width) ;;Emacs 26.1 or later + (ceiling + (save-excursion ;;なぜかpointが変わることがある。redisplay中だから？ + (if window + (with-selected-window window + (line-number-display-width 'columns)) + (line-number-display-width 'columns)))) + 0)))) + + + +;;;; Area Display + + +(defvar-local phscroll-fontify-range nil + "Fontifying range (BEG . END).") + +(defun phscroll-update-area-display (area &optional redraw window) + (when (and area (not phscroll-truncate-lines)) + ;;(message "update-area-display %s redraw=%s window-width=%s" area redraw (window-width window)) + (if (or (phscroll-area-window-width-changed-p area window) ;;First, update area.window-width + redraw) + (phscroll-area-clear-updated-ranges area)) + + (let* ((scroll-column (phscroll-get-scroll-column area)) + (area-begin (phscroll-area-begin area)) + (area-end (phscroll-area-end area)) + ;; If in fontify, do not use window-begin and window-end. + ;; area-begin, area-end are already windowed. + (update-begin (max area-begin + (point-min) ;;narrowed + (if phscroll-fontify-range + (phscroll-line-begin + (car phscroll-fontify-range)) + (phscroll-line-begin + (phscroll-window-start window))))) + (update-end (min area-end + (point-max) ;;narrowed + (if phscroll-fontify-range + (cdr phscroll-fontify-range) + (phscroll-window-end window))))) + + ;;(message "update-area-display %s redraw=%s window-width=%s update-range=(%s %s)" area redraw (window-width window) update-begin update-end) + + (when (and (< update-begin update-end) + (phscroll-area-needs-update-range update-begin update-end area)) + ;; for each lines + (phscroll-update-area-lines-display area scroll-column update-begin update-end window) + ;; add updated range + (phscroll-area-add-updated-range update-begin update-end area) + )))) + +(defun phscroll-update-area-lines-display (area scroll-column update-begin update-end window) + (save-excursion + ;; Ensure that the update range is within the point movable range. + (when (< update-begin (point-min)) + (setq update-begin (point-min))) + (when (> update-end (point-max)) + (setq update-end (point-max))) + + (goto-char (phscroll-line-begin update-begin)) + + (while (< (point) update-end) + (let ((line-begin (phscroll-line-begin)) + (line-end (phscroll-line-end))) + (when (phscroll-area-needs-update-range line-begin line-end area) + ;;(message "update line %d" (point)) + (remove-overlays line-begin (1+ line-end) 'phscroll-left t) ;;include line-break + (remove-overlays line-begin (1+ line-end) 'phscroll-right t) ;;include line-break + (save-excursion + (phscroll-update-current-line-display scroll-column window))) + ;; goto next line + (forward-line))))) + +(defun phscroll-update-current-line-display (scroll-column window) + ;; | line | + ;; | left(9) | middle(14) | right | scroll-column 0) + (let ((ov (make-overlay line-begin (+ line-begin left-len)))) + (overlay-put ov 'display (if phscroll-use-fringe + '(left-fringe left-arrow) + "<")) + (overlay-put ov 'after-string (make-string left-overflow ?\s)) + (overlay-put ov 'phscroll t) + (overlay-put ov 'phscroll-left t) + (overlay-put ov 'evaporate t) + (overlay-put ov 'priority 10))) + + (when (< (+ line-begin left-len middle-len) line-end) + (let ((ov (make-overlay (+ line-begin left-len middle-len) line-end))) + (overlay-put ov 'display + (if phscroll-use-fringe + '(right-fringe right-arrow) + (concat (make-string middle-shortage ?\s) ">"))) + (overlay-put ov 'phscroll t) + (overlay-put ov 'phscroll-right t) + (overlay-put ov 'evaporate t) + (overlay-put ov 'priority 10))) + )) + + + +;;;; Text Utilities + + +(defun phscroll-line-begin (&optional pos) + (let ((inhibit-field-text-motion t)) + (if pos + (save-excursion (goto-char pos) (line-beginning-position)) + (line-beginning-position)))) + +(defun phscroll-line-end (&optional pos) + (let ((inhibit-field-text-motion t)) + (if pos + (save-excursion (goto-char pos) (line-end-position)) + (line-end-position)))) + +;; Text Operation Like a String + +(defun phscroll-buffer-substring (beg end) + ;;ignore-overlay: (buffer-substring-no-properties beg end) + (cons beg end) + ) + +(defun phscroll-current-line-string () + (phscroll-buffer-substring (phscroll-line-begin) (phscroll-line-end))) + +(defun phscroll-string-length (str) + ;;ignore-overlay: (length str) + (- (cdr str) (car str)) + ) + +(defun phscroll-substring (str &optional from to) + ;;ignore-overlay: (substring str from to) + (cons + (if (null from) (car str) (+ (car str) from)) + (if (null to) (cdr str) (+ (car str) to))) + ) + + +;; Overlay Cache for Text Width Calculation + +(defun phscroll-ovc-create (type pvalue ov) + (list type + pvalue + ov + (overlay-start ov) + (overlay-end ov) + (overlay-get ov 'priority))) +(defun phscroll-ovc-type (ovc) (car ovc)) +(defun phscroll-ovc-pvalue (ovc) (nth 1 ovc)) +(defun phscroll-ovc-ov (ovc) (nth 2 ovc)) +(defun phscroll-ovc-beg (ovc) (nth 3 ovc)) +(defun phscroll-ovc-end (ovc) (nth 4 ovc)) +(defun phscroll-ovc-priority (ovc) (or (nth 5 ovc) 0)) +(defun phscroll-ovc-less (ovc1 ovc2) + (let ((dstart (- (phscroll-ovc-beg ovc1) (phscroll-ovc-beg ovc2)))) + (or (< dstart 0) + (and (= dstart 0) + (> (phscroll-ovc-priority ovc1) + (phscroll-ovc-priority ovc2)))))) + +(defun phscroll-get-overlay-cache (beg end) + (let* ((overlays (overlays-in beg end)) + (iter overlays)) + ;; filter overlays + (while iter + (let* ((ov (car iter)) + pvalue) + (cond + ;; ignore phscroll's overlay + ((overlay-get ov 'phscroll) + (setcar iter nil)) + ((overlay-get ov 'phscroll-ignore) + (setcar iter nil)) + ;; 'display + ((setq pvalue (overlay-get ov 'display)) + (setcar iter (phscroll-ovc-create 'display pvalue ov))) ;;reuse a cons cell of overlays list + ;; 'invisible + ((and (setq pvalue (overlay-get ov 'invisible)) + (not (eq pvalue 'outline))) ;;ignore outline invisible overlay + (setcar iter (phscroll-ovc-create 'invisible pvalue ov))) ;;reuse a cons cell of overlays list + ;; not supported type + (t + (setcar iter nil)))) + (setq iter (cdr iter))) + + ;; delete nil + (setq overlays (delq nil overlays)) + ;; sort by overlay-start and priority + (sort overlays #'phscroll-ovc-less))) + +(defun phscroll-get-overlay-at (pos cache) + ;;discard ovc.end <= pos + (while (and cache (<= (phscroll-ovc-end (car cache)) pos)) + (setq cache (cdr cache))) + + (when (and cache + (<= (phscroll-ovc-beg (car cache)) pos)) ;; ovc.beg <= pos + (car cache))) + +;; Character Width Calculation + +(defun phscroll-char-width-next (pos cache) + (let (ovc display invisible) + (cond + ;; overlays + ((setq ovc (phscroll-get-overlay-at pos cache)) + (pcase (phscroll-ovc-type ovc) + ('display (cons + (phscroll-display-property-width (phscroll-ovc-pvalue ovc)) + (phscroll-ovc-end ovc))) + ('invisible (cons + (phscroll-invisible-property-width + (phscroll-ovc-pvalue ovc) + (phscroll-ovc-beg ovc) + (phscroll-ovc-end ovc)) + (phscroll-ovc-end ovc))) + (_ (cons 1 (1+ pos))))) + + ;; display text property + ((setq display (get-text-property pos 'display)) + (cons + (phscroll-display-property-width display) + (1+ pos))) + ;; invisible text property + ((setq invisible (get-text-property pos 'invisible)) + (cons + (phscroll-invisible-property-width invisible pos (1+ pos)) + (1+ pos))) + ;; normal character + (t + (cons + (char-width (char-after pos)) + (1+ pos)))))) + +(defun phscroll-display-property-width (display) + ;; https://www.gnu.org/software/emacs/manual/html_node/elisp/Display-Property.html#Display-Property + ;;@todo support more formats + (cond + ;; string + ((stringp display) + (string-width display)) + ;; list + ((listp display) + (cond + ((eq (car display) 'space) + (let* ((props (cdr display))) + (+ + (phscroll-resolve-space-pixel-spec-chars (plist-get props :width)) + (let ((factor (plist-get props :relative-width))) + (if (numberp factor) (ceiling factor) 0))))) ;;@todo (* factor (char-width )) + (t 0))) + ;; unknown + (t 0))) + +(defun phscroll-resolve-space-pixel-spec-chars (spec) + (cond + ((null spec) 0) + ((integerp spec) spec) + ((floatp spec) (ceiling spec)) + ((symbolp spec) + (phscroll-resolve-space-pixel-spec-chars (ignore-errors (symbol-value spec)))) + ((and (consp spec) (null (cdr spec))) + (ceiling + (/ + (phscroll-resolve-space-pixel-spec-chars (car spec)) + (default-font-width)))) + (t 0))) + +(defun phscroll-invisible-property-width (invisible beg end) + ;; https://www.gnu.org/software/emacs/manual/html_node/elisp/Invisible-Text.html + ;;@todo Detect changes in buffer-invisibility-spec. + (pcase (invisible-p invisible) ;; Consider buffer-invisibility-spec. + ('nil (string-width (buffer-substring-no-properties beg end))) + ('t 0) + (_ + (if (and (>= beg (point-min)) (invisible-p (1- beg))) + ;; Not first position in invisible region. + 0 + ;; Calculate the width of the current ellipsis string. + (string-width + (apply #'string (seq-map #'glyph-char + (or (display-table-slot buffer-display-table 4) + [?. ?. ?.])))))))) + +;; Text Width Calculation + +(defun phscroll-text-width (beg end &optional cache-arg) + (let ((width 0) + (pos beg) + (cache (or cache-arg (phscroll-get-overlay-cache beg end)))) + (while (< pos end) + (let ((width-next (phscroll-char-width-next pos cache))) + (setq width (+ width (car width-next))) + (setq pos (cdr width-next)))) + width)) + +(defun phscroll-string-width (str &optional cache) + ;;ignore-overlay: (string-width str) + (phscroll-text-width (car str) (cdr str) cache) + ) + +(defun phscroll-truncate-string-to-width (str end-column &optional cache-arg) + ;;ignore-overlay: (truncate-string-to-width str end-column) + (let* ((width 0) + (prev-width 0) + (beg (car str)) + (end (cdr str)) + (pos beg) + (prev-pos pos) + (cache (or cache-arg (phscroll-get-overlay-cache beg end)))) + (while (and (< pos end) (<= width end-column)) + (let ((width-next (phscroll-char-width-next pos cache))) + (setq prev-pos pos) + (setq prev-width width) + (setq width (+ width (car width-next))) + (setq pos (cdr width-next)))) + (if (> width end-column) + (cons (cons beg prev-pos) prev-width) + (cons (cons beg pos) width)))) + +(defun phscroll-substring-over-width (str end-column &optional cache-arg) + ;;ignore-overlay: + ;; (let ((len (phscroll-string-length str)) + ;; (i 0)) + ;; (while (and (< i len) (< (phscroll-string-width (phscroll-substring str 0 i)) end-column)) + ;; (setq i (1+ i))) + ;; (phscroll-substring str 0 i)) + (let* ((width 0) + (beg (car str)) + (end (cdr str)) + (pos beg) + (cache (or cache-arg (phscroll-get-overlay-cache beg end)))) + (while (and (< pos end) (< width end-column)) + (let ((width-next (phscroll-char-width-next pos cache))) + (setq width (+ width (car width-next))) + (setq pos (cdr width-next)))) + (cons (cons beg pos) width))) + + +;; Text Width Calculation (In Pixels) + +(defun phscroll-truncate-string-to-width-px (str end-column) + (let* ((beg (car str)) + (end (cdr str)) + (pos-and-width (phscroll-find-max-pos-fits-in-width-px + beg end (* (frame-char-width) end-column))) + (pos (car pos-and-width)) + (width (cdr pos-and-width))) + + (cons (cons beg pos) + (/ (+ width (frame-char-width) -1) (frame-char-width))))) + +(defun phscroll-find-max-pos-fits-in-width-px (beg end width &optional window) + ;; Temporarily unveil folded text + (let ((overlays (cl-loop for ov in (overlays-in beg end) + for invis = (overlay-get ov 'invisible) + when (or (eq invis 'outline) (assq 'outline invis)) + collect (progn + (overlay-put ov 'invisible nil) + (cons ov invis))))) + (unwind-protect + (let ((lower beg) + (upper (1+ end)) ;; Possible answers include END + (prefix-width (car (window-text-pixel-size nil beg beg 1000000))) + lower-width) + + (while (> (- upper lower) 1) + (let* ((pos (/ (+ lower upper) 2)) ;;floor (Never test UPPER) + (pos-width (- (car (window-text-pixel-size window beg pos 1000000)) + prefix-width))) + (if (<= pos-width width) + (setq lower pos + lower-width pos-width) + (setq upper pos)))) + (cons lower (or lower-width 0))) + ;; Recover invisible property + (dolist (ov-invis overlays) + (overlay-put (car ov-invis) 'invisible (cdr ov-invis)))))) + + + + +;; Example: +;;asjflasjfl;asjfl;asjfl;asjflasjlf;kajsl;fkjasl;fjasl;fjaslkfjals;fjasklfjasldf +;;1ちまはりちまとりれはちてりはくちれくはれちとくはちくとれはくちとれはちはちとまはりちとまはりとちれは +;;ちまはりちまafasfsdfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff$ +;; とりれはちてりはくちれくはれちとくはちくとれはくちとれはちはちとまはりちとまはりとちれは +;;ちまはりちまとりれはちてりはくちれくはれちとくはちくとれはくちとれはちはちとまはりちとまはりとちれは + + + +(provide 'phscroll) +;;; phscroll.el ends here