├── .gitignore ├── other ├── .gitignore ├── example.lisp ├── test2.lisp └── test.lisp ├── package.lisp ├── README.md ├── lem-opengl.asd ├── LICENSE ├── doc ├── hamayama.txt └── TODO ├── impl.lisp ├── keys.lisp └── sucle.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ -------------------------------------------------------------------------------- /other/.gitignore: -------------------------------------------------------------------------------- 1 | themes.lisp -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :lem-sucle 2 | (:use :cl :ncurses-clone-for-lem)) 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lem-opengl 2 | 3 | This is a frontend for [lem](https://github.com/cxxxr/lem). 4 | It is based on the ncurses frontend. 5 | It renders lem to an OpenGL texture, making it easy to use in OpenGL enabled apps. 6 | Input and windowing is handled by [https://github.com/terminal625/sucle](https://github.com/terminal625/sucle) which is not yet available on quicklisp. 7 | 8 | click for video: 9 | [![lem opengl](https://img.youtube.com/vi/JgUADI7axC8/0.jpg)](https://www.youtube.com/watch?v=JgUADI7axC8) 10 | -------------------------------------------------------------------------------- /other/example.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:lem-sucle 2 | (:use :cl)) 3 | (in-package :lem-sucle) 4 | 5 | (setf lem-sucle::*run-sucle* t) 6 | (lem-paredit-mode:paredit-mode) 7 | 8 | (dotimes (x 100) 9 | (print x)) 10 | 11 | (defparameter *an-overlay* 12 | (our-make-overlay 13 | (lem:current-point) 14 | (lem:save-excursion 15 | (lem:forward-char 100) 16 | (lem:copy-point (lem:current-point) :temporary)) 17 | (copy-attribute-to-sucle-attribute 'lem:cursor))) 18 | 19 | (our-delete-overlay *an-overlay*) 20 | 21 | ;;data is stored in the overlay plist? 22 | 23 | 24 | (delete-all-overlays) 25 | 26 | 27 | (foo 1 2 3) 28 | hello world? -------------------------------------------------------------------------------- /lem-opengl.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lem-opengl" 2 | :depends-on ( 3 | #:ncurses-clone-for-lem 4 | ;;"cl-charms" 5 | "control" 6 | "trivial-clipboard" 7 | ;;#+(or (and ccl unix) (and lispworks unix))"lem-setlocale" 8 | "minilem" 9 | 10 | #:application 11 | #:utility 12 | ;;#:opengl-immediate 13 | ;;#:character-modifier-bits 14 | #:uncommon-lisp 15 | #:livesupport 16 | 17 | #:sucle) 18 | :serial t 19 | :components ((:file "package") 20 | (:file "impl") 21 | (:file "keys") 22 | (:file "sucle") 23 | (:module "other" 24 | :components 25 | ((:file "test") 26 | (:file "test2"))))) 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 terminal625 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /doc/hamayama.txt: -------------------------------------------------------------------------------- 1 | Taken from: https://gist.github.com/Hamayama/71ba25e9567b64ca855a5b8f7439add5 2 | 3 | < verification of lem's OpenGL front-end> 4 | 5 | 6 | (1)environment 7 | OS : Windows 8.1 (64bit) 8 | Development environment: MSYS2/MinGW-w64 (64bit) (gcc version 7.3.0 (Rev2, Built by MSYS2 project)) 9 | 10 | (2)installation 11 | pacman-S mingw-w64-x86_64-glfw 12 | ros install terminal625/utility 13 | ros install terminal625/sucle 14 | After the execution of、 15 | https://github.com/cxxxr/lem/pull/355 16 | Copy the opengl folder to the frontends folder of the lem、 17 | frontends/opengl/term.remove `#+win32 (charms/ll:use-default-colors)` from line 513 of lisp 18 | 19 | (3) start-up 20 | create lem-opengl based on lem-ncurses 21 | ros-Q-m lem-opengl-L sbcl-bin -- $USERPROFILE/.roswell / bin/lem-opengl 22 | 23 | (4) confirmation 24 | Start-up-allowed 25 | Exit - yes 26 | When you exit the app, you will see a lot of the following 27 | NIL :LEFT-CONTROL key unimplemented:LEFT-CONTROL key unimplemented ... 28 | Screen display → yes 29 | The display is fast!! 30 | The color looks a little strange.。。(←It was a misunderstanding mod the color of modeline is sometimes strange) 31 | Screen resize → disable 32 | Screen maximization → not available 33 | This is a great app. 34 | Key input → US specification? 35 | C-space → C-` 36 | C-shift - " → C-space 37 | shift -" → @ 38 | shift-& → ^ 39 | shift -' & 40 | shift - ( * 41 | shift -) → ( 42 | shift-0 → ) 43 | shift-- → _ 44 | shift-~ → + 45 | shift - \ → none 46 | shift -@ → { 47 | shift - [→ } 48 | shift -; → : 49 | shift -: " 50 | shift-] → | 51 | shift -/→? 52 | shift-backslash → none 53 | ^ → = 54 | \ → None 55 | @ → [ 56 | [ ] 57 | : → ' 58 | ]- >Backslash 59 | Backslash = no 60 | Japanese input → not available 61 | This is a great app, but it needs a lot of work. 62 | This is a great app, but it needs a lot of work. 63 | Move cursor by mouse → enable 64 | Copy&paste by mouse → not available 65 | Scrollable by wheel 66 | In C-x 2, you can divide the screen vertically. 67 | In C-x 3, you can divide the screen horizontally. 68 | There is no display of the dividing line, and the garbage remains there 69 | Move the dividing line with the mouse 70 | 71 | 72 | (2018-12-16)(2018-12-17) 73 | -------------------------------------------------------------------------------- /doc/TODO: -------------------------------------------------------------------------------- 1 | ;;render unicode, specifically japanese 2 | ;; ->use vecto or something. the super fast text grid might be overkill. 3 | ;; -> tack on unicode characters after rendering to the super fast text grid? 4 | ;;be able to reload lem without errors 5 | ;; -> actually just never close lem. figuring out how to tear it down and up again seems too hard for now. 6 | ;;fix wide characters for ncurses-clone 7 | ;; -> for now, it just renders placeholders 8 | ;;does lem have line wrapping? 9 | ;; -> seemingly, no, the line wrapping feature of ncurses is not used? 10 | ;;cursor position is based on character widths? 11 | ;;but window position is not? 12 | ;;character width depends on where it is? tab? 13 | ;;add selecting regions with the mouse? 14 | 15 | ;;lem has lexcial variables found in lem.lisp that are named "once" which set only once. disable? 16 | ;;FIXME::what is stdscr supposed to do? is it transparent? 17 | 18 | ;;FIXME::correctly render the vertical bar between windows 19 | ;;FIXME::when characters overwrite wide characters 20 | ;;FIXME::resolution blurry when width thin and height tall 21 | ;;FIXME::don't use 'virtual window', use *std-scr*? 22 | 23 | ;;Noob mode-> z undo x delete c copy v paste keys, region selecting with the mouse 24 | 25 | ;;FIXME::multithreading problems? lem send-event? 26 | ;;just got rid of lem:send-event and called in the same thread. multithreading problem? 27 | ;;FIXME::lisp repl flashing when entering on the last char? 28 | ;;FIXME::off center mouse pointer 29 | ;;FIXME::The control button does not seem to work on windows 30 | 31 | ;;FIXME::This seems to be a lem rendering bug. 32 | ;;if you mark a region, scroll down with the point until the region fills the screen, 33 | ;;then up again, on the first line the whole screen will be highlighted 34 | ;;see: 35 | ;;https://github.com/cxxxr/lem/pull/374/commits/e16af46a658c289d27a0919808c4ac14c8948104 36 | 37 | ;;FIXME::get rid of ncurses-color pairs. Just store the foreground and background 38 | ;;8 bits char, 8 fg, 8 bg, 1 reverse 1 bold 1 underline = 27 bits, 30 bit fixnum of 39 | ;;32 bit lisp machines 40 | 41 | ;;FIXME::lem bug where moving the cursor to a long, wrapping line causes 42 | ;;the beginning of the line to be forced into view. Then scrolling down with the cursor, 43 | ;;the cursor can leave the screen. Scrolling on wrapping lines causes window to jump up 44 | 45 | ;;FIXME::improper window draggin when 3 or more divisions 46 | ;;FIXME::still improper window dragging. has to do with window tree structure? -------------------------------------------------------------------------------- /other/test2.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lem-sucle) 2 | (defun empty-overlay-p (overlay) 3 | (lem:point= 4 | (lem:overlay-start overlay) 5 | (lem:overlay-end overlay))) 6 | 7 | (defparameter *overlays* (make-hash-table :test 'eq)) 8 | (defun remove-overlays-of-buffer (buffer) 9 | (remhash buffer *overlays*)) 10 | 11 | (defun delete-all-overlays () 12 | (utility:dohash (k v) *overlays* 13 | (declare (ignorable k)) 14 | (mapc 'our-delete-overlay v) 15 | ;;FIXME::remove the 16 | )) 17 | 18 | (defun remove-empty-overlays-of-buffer (buffer) 19 | (let* ((data (gethash buffer *overlays*)) 20 | (to-delete (remove-if-not 'empty-overlay-p 21 | data))) 22 | (when to-delete 23 | ;;FIXME::plural format string? formatter? 24 | (format *output* "~%deleting ~a overlays" (length to-delete)) 25 | (mapc 'our-delete-overlay 26 | to-delete)))) 27 | 28 | (defun our-make-overlay (start end attribute) 29 | (let* ((overlay (lem:make-overlay start end attribute)) 30 | (buffer (lem:overlay-buffer overlay))) 31 | (unless (gethash buffer *overlays*) 32 | (lem:add-hook 33 | (lem:variable-value 'lem:kill-buffer-hook :buffer 34 | buffer) 35 | 'remove-overlays-of-buffer) 36 | (lem:add-hook 37 | (lem:variable-value 'lem:after-change-functions :buffer 38 | buffer) 39 | 'foo)) 40 | (setf (lem-sucle::sucle-attribute-overlay attribute) 41 | overlay) 42 | (push overlay (gethash buffer *overlays*)) 43 | overlay)) 44 | 45 | (defparameter *output* *standard-output*) 46 | (defun foo (&rest rest) 47 | (destructuring-bind (start end len) rest 48 | (declare (ignore end len)) 49 | (let ((buffer (lem:point-buffer start))) 50 | (remove-empty-overlays-of-buffer buffer)) 51 | ;;(print rest *output*) 52 | )) 53 | 54 | (defun our-delete-overlay (overlay) 55 | (let ((buffer (lem:overlay-buffer overlay))) 56 | (lem:delete-overlay overlay) 57 | (let ((value (gethash buffer *overlays*))) 58 | (if value 59 | (progn 60 | (let ((new-list (delete overlay value))) 61 | (if new-list 62 | (setf (gethash buffer *overlays*) 63 | new-list) 64 | (progn 65 | (remhash buffer *overlays*) 66 | (lem:remove-hook 67 | (lem:variable-value 'lem:kill-buffer-hook :buffer 68 | buffer) 69 | 'remove-overlays-of-buffer) 70 | (lem:remove-hook 71 | (lem:variable-value 'lem:after-change-functions :buffer 72 | buffer) 73 | 'foo)))) 74 | t) 75 | nil)))) 76 | 77 | (defun copy-attribute-to-sucle-attribute (attribute) 78 | (let ((attribute (lem:ensure-attribute attribute t))) 79 | (make-instance 80 | 'lem-sucle::sucle-attribute 81 | :underline-p (lem:attribute-underline-p attribute) 82 | :bold-p (lem:attribute-bold-p attribute) 83 | :reverse-p (lem:attribute-reverse-p attribute) 84 | :background (lem:attribute-background attribute) 85 | :foreground (lem:attribute-foreground attribute) 86 | ))) 87 | 88 | ;;TODO:subclass lem:attribute in order to attach extra data to attributes 89 | ;;have one attribute per overlay? 90 | -------------------------------------------------------------------------------- /impl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lem-sucle) 2 | 3 | (defclass sucle (lem:implementation) 4 | () 5 | (:default-initargs 6 | :native-scroll-support nil 7 | :redraw-after-modifying-floating-window t)) 8 | (setf lem:*implementation* (make-instance 'sucle)) 9 | 10 | (define-condition exit-editor (lem:editor-condition) 11 | ((value 12 | :initarg :value 13 | :reader exit-editor-value 14 | :initform nil))) 15 | 16 | (defun sync-lem-windows-and-ncurses-views () 17 | (lem::window-tree-map 18 | (lem::window-tree) 19 | (lambda (window) 20 | (let ((view (lem:window-view window))) 21 | (when view ;;FIXME::what can this be? 22 | (setf (ncurses-clone-lem-view:ncurses-view-parent-window view) 23 | window)))))) 24 | 25 | ;;;; 26 | (defclass sucle-attribute (lem:attribute) 27 | ((overlay 28 | :initarg :overlay 29 | :initform nil 30 | :accessor sucle-attribute-overlay))) 31 | ;;;; 32 | 33 | 34 | (defparameter *editor-thread* nil) 35 | (defun invoke (function) 36 | (when (or (null *editor-thread*) 37 | (not (bt:thread-alive-p *editor-thread*))) 38 | (print "starting editor thread") 39 | (let (;;(result nil) 40 | (input-thread (bt:current-thread))) 41 | (setf ncurses-clone::*char-width-at-fun* #'lem-base:char-width) 42 | (setf *editor-thread* 43 | (funcall function 44 | nil 45 | (lambda (report) 46 | (bt:interrupt-thread 47 | input-thread 48 | (lambda () 49 | (print report) 50 | (error 'exit-editor :value report)))))) 51 | #+nil 52 | (setf result (input-loop editor-thread)) 53 | #+nil 54 | (when (and (typep result 'exit-editor) 55 | (exit-editor-value result)) 56 | (format t "~&~A~%" (exit-editor-value result)))))) 57 | (defmethod lem-if:invoke ((implementation sucle) function) 58 | ;;FIXME::Factor out term-init? 59 | (invoke function)) 60 | (defmethod lem-if:display-background-mode ((implementation sucle)) 61 | (ncurses-clone-lem-view:display-background-mode)) 62 | (defmethod lem-if:update-foreground ((implementation sucle) color-name) 63 | (ncurses-clone-lem-view:update-foreground color-name)) 64 | (defmethod lem-if:update-background ((implementation sucle) color-name) 65 | (ncurses-clone-lem-view:update-background color-name)) 66 | (defmethod lem-if:display-width ((implementation sucle)) 67 | (ncurses-clone-lem-view:display-width)) 68 | (defmethod lem-if:display-height ((implementation sucle)) 69 | (ncurses-clone-lem-view:display-height)) 70 | (defmethod lem-if:make-view ((implementation sucle) window x y width height use-modeline) 71 | (declare (ignorable window)) 72 | (ncurses-clone-lem-view:make-view x y width height use-modeline)) 73 | (defmethod lem-if:delete-view ((implementation sucle) view) 74 | (ncurses-clone-lem-view:delete-view view)) 75 | (defmethod lem-if:clear ((implementation sucle) view) 76 | (ncurses-clone-lem-view:clear view)) 77 | (defmethod lem-if:set-view-size ((implementation sucle) view width height) 78 | (ncurses-clone-lem-view:set-view-size view width height (lem:minibuffer-window-height))) 79 | (defmethod lem-if:set-view-pos ((implementation sucle) view x y) 80 | (ncurses-clone-lem-view:set-view-pos view x y)) 81 | 82 | (defun attribute-to-bits (attribute-or-name) 83 | (let ((attribute (lem:ensure-attribute attribute-or-name nil)) 84 | ;;(cursorp (eq attribute-or-name 'lem:cursor)) 85 | ) 86 | (if (null attribute) 87 | 0 88 | (or (lem::attribute-%internal-value attribute) 89 | (let ((bits 90 | (lem.term::get-attribute-bits-2 91 | (lem:attribute-foreground attribute) 92 | (lem:attribute-background attribute) 93 | (lem::attribute-bold-p attribute) 94 | (lem::attribute-underline-p attribute) 95 | (lem::attribute-reverse-p attribute)))) 96 | (setf (lem::attribute-%internal-value attribute) bits) 97 | bits))))) 98 | 99 | (defmacro with-attribute-and-view ((attribute view) &body body) 100 | (alexandria:once-only (attribute) 101 | `(ncurses-clone::with-attributes 102 | ((attribute-to-bits ,attribute) (list ,attribute ,view) 103 | (typep ,attribute 'sucle-attribute)) 104 | ,@body))) 105 | (defmethod lem-if:print ((implementation sucle) view x y string attribute) 106 | ;;FIXME::different names 107 | (with-attribute-and-view (attribute view) 108 | (ncurses-clone-lem-view:print-into-view view x y string))) 109 | (defmethod lem-if:print-modeline ((implementation sucle) view x y string attribute) 110 | (with-attribute-and-view (attribute view) 111 | (ncurses-clone-lem-view:print-modeline view x y string))) 112 | (defmethod lem-if:clear-eol ((implementation sucle) view x y) 113 | (ncurses-clone-lem-view:clear-eol view x y)) 114 | (defmethod lem-if:clear-eob ((implementation sucle) view x y) 115 | (ncurses-clone-lem-view:clear-eob view x y)) 116 | 117 | ;;(defparameter *no* *standard-output*) 118 | (defmethod lem-if:redraw-view-after ((implementation sucle) view focus-window-p) 119 | (declare (ignore focus-window-p)) 120 | (with-attribute-and-view ('lem:modeline view) 121 | (ncurses-clone-lem-view:redraw-view-after view))) 122 | (defmethod lem-if:update-display ((implementation sucle)) 123 | (ncurses-clone-lem-view:update-display) 124 | (sync-lem-windows-and-ncurses-views)) 125 | (defmethod lem-if:scroll ((implementation sucle) view n) 126 | (ncurses-clone-lem-view:scroll view n)) 127 | (defmethod lem-if:clipboard-paste ((implementation sucle)) 128 | (trivial-clipboard:text)) 129 | (defmethod lem-if:clipboard-copy ((implementation sucle) text) 130 | (trivial-clipboard:text text)) 131 | 132 | (pushnew :lem-sucle *features*) 133 | -------------------------------------------------------------------------------- /other/test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lem-sucle) 2 | 3 | (lem:define-command forward2 (&optional (n 1)) ("p") 4 | (lem:forward-char 1) 5 | (lem-paredit-mode:paredit-forward n)) 6 | ;;https://www.gnu.org/software/emacs/manual/html_node/elisp/Interactive-Codes.html 7 | ;;This is what "p" and "r" are for? 8 | (defun start-lem () 9 | (let ((lem::*in-the-editor* nil)) 10 | ;;(lem:main nil) 11 | ;;#+nil 12 | (lem:add-hook lem:*find-file-hook* 13 | (lambda (buffer) 14 | (when (eq (lem:buffer-major-mode buffer) 'lem-lisp-mode:lisp-mode) 15 | (lem:change-buffer-mode buffer 'lem-paredit-mode:paredit-mode t)))) 16 | (setf lem.term::*ansi-color-names-vector* 17 | ;;from misterioso 18 | (mapcar 'lem:parse-color 19 | (remove-duplicates '("#2d3743" "#ff4242" "#74af68" "#dbdb95" 20 | "#34cae2" "#008b8b" "#00ede1" "#e1e1e0" 21 | ;;above were from ansi-color-names-vector 22 | ;;https://github.com/jwiegley/emacs-release/blob/master/etc/themes/misterioso-theme.el 23 | "#878787" "#eeeeec" "#415160" "#2d4948" 24 | "#212931" "#729fcf" "#23d7d7" "#ffad29" 25 | "#e67128") 26 | :test 'string=))) 27 | (lem.term::regen-color-array) 28 | (progn 29 | (define-sacred-keys) 30 | ;;(define-other-keys) 31 | (lem:define-key lem:*global-keymap* "C-/" 'lem:undo) 32 | (lem:define-key lem.language-mode:*language-mode-keymap* "Tab" 'indent-region-or-otherwise) 33 | (lem:define-key lem:*global-keymap* "Tab" 'indent-region-or-otherwise) 34 | (lem:define-key lem-paredit-mode:*paredit-mode-keymap* "C-k" 'lem:kill-sexp) 35 | (lem:define-key lem-lisp-mode:*lisp-mode-keymap* "C-k" 'lem:kill-sexp) 36 | (lem:define-key lem-paredit-mode:*paredit-mode-keymap* ")" 'forward2) 37 | (lem:define-key lem.listener-mode:*listener-mode-keymap* "C-Down" 38 | 'lem.listener-mode:listener-next-input) 39 | (lem:define-key lem.listener-mode:*listener-mode-keymap* "C-Up" 40 | 'lem.listener-mode:listener-prev-input) 41 | (lem:define-key lem:*global-keymap* "Return" 42 | 'lem.language-mode:newline-and-indent) 43 | (progn 44 | ;;FIXME::where to put this? 45 | (lem::clear-all-attribute-cache) 46 | #+nil 47 | (ncurses-clone::reset-ncurses-color-pairs) 48 | #+nil 49 | (lem.term::reset-color-pair)) 50 | (lem:lem) 51 | (lem:send-event 52 | (lambda () 53 | (lem:find-file (merge-pathnames "other/example.lisp" 54 | (asdf:system-source-directory :lem-opengl))) 55 | (lem-paredit-mode:paredit-mode) 56 | (lem:load-theme "misterioso")))) 57 | (lem-sucle::input-loop))) 58 | 59 | (in-package :lem-user) 60 | 61 | (define-color-theme "misterioso" () 62 | ;;(display-background-mode :dark) 63 | (foreground "#e1e1e0") ;; 64 | (background ;;"#3a3a3a" ;; 65 | "#2d3743" 66 | ) 67 | (cursor :background "#415160" 68 | ;;FIXME::what is the correct foreground? ;;not perfect, not same as modeline background, 69 | ;;but good enough? 70 | :foreground "#212931") ;; 71 | (region :background "#2d4948" :foreground "#e1e1e0") ;; 72 | (modeline :background "#212931" :foreground "#eeeeec") ;; 73 | (modeline-inactive :background "#878787" :foreground "#eeeeec");; 74 | (minibuffer-prompt-attribute :foreground "#729fcf" :bold-p t) ;; 75 | (syntax-builtin-attribute :foreground "#23d7d7") ;; 76 | (syntax-comment-attribute :foreground "#74af68");; 77 | (syntax-constant-attribute :foreground "#008b8b");; 78 | (syntax-function-name-attribute :foreground "#00ede1" :bold-p t);; 79 | (syntax-keyword-attribute :foreground "#ffad29" :bold-p t);; 80 | (syntax-string-attribute :foreground "#e67128");; 81 | (syntax-type-attribute :foreground "#34cae2") ;; 82 | (syntax-variable-attribute :foreground "#dbdb95") ;; 83 | (syntax-warning-attribute :foreground "#dbdb95" :bold-p t)) 84 | (in-package :lem-sucle) 85 | 86 | ;;https://en.wikipedia.org/wiki/Keyboard_shortcut 87 | ;;FIXME::cross-platform unified interface, or per-OS interface? 88 | ;;C-X, C-G, M-X 89 | (defun define-sacred-keys () 90 | (lem:define-key lem:*global-keymap* "Delete" 'delete-region-or-char) 91 | (lem:define-key lem:*global-keymap* "Backspace" 'delete-region-or-char) 92 | (lem:define-key lem:*global-keymap* "C-z" 'lem:undo) 93 | #+nil 94 | (progn 95 | (lem:define-key lem:*global-keymap* "C-a" 'lem::mark-set-whole-buffer) 96 | (lem:define-key lem:*global-keymap* "C-s" 'lem:save-buffer) 97 | (lem:define-key lem:*global-keymap* "C-f" 'lem.isearch:isearch-forward) 98 | ;;FIXME::C-G? 99 | (lem:define-key lem:*global-keymap* "C-v" 'lem:paste-from-clipboard) 100 | (lem:define-key lem:*global-keymap* "C-x" 'delete-region) 101 | (lem:define-key lem:*global-keymap* "C-c" 'lem:copy-region)) 102 | 103 | ;;(lem:define-key lem:*global-keymap* "C-c" 'lem:yank) 104 | ) 105 | 106 | (defun define-other-keys () 107 | (lem:define-key lem:*global-keymap* "C-?" 'lem:describe-key)) 108 | 109 | (lem:define-command delete-region-or-char () () 110 | (let ((buffer (lem:current-buffer))) 111 | (if (lem:buffer-mark-p buffer) 112 | (%delete-region buffer) 113 | (;;lem:delete-character ;;FIXME::dispatch on mode? 114 | lem-paredit-mode:paredit-backward-delete)))) 115 | 116 | (lem:define-command indent-region-or-otherwise () () 117 | (let ((buffer (lem:current-buffer))) 118 | (if (lem:buffer-mark-p buffer) 119 | (progn 120 | (print 3434) 121 | (lem:indent-region (lem:buffer-mark buffer) 122 | (lem:buffer-point buffer))) 123 | (lem.language-mode::indent-line-and-complete-symbol)))) 124 | 125 | (lem:define-command delete-region () () 126 | (let ((buffer (lem:current-buffer))) 127 | (when (lem:buffer-mark-p buffer) 128 | (%delete-region buffer)))) 129 | 130 | 131 | (defun %delete-region (buffer) 132 | (lem:delete-between-points 133 | (lem:buffer-mark buffer) 134 | (lem:buffer-point buffer))) 135 | 136 | #+nil ;;FIXME::remove this unused code? 137 | (progn 138 | (defparameter *packages* nil) 139 | (defun find-lem-package () 140 | (remove-if-not (lambda (x) 141 | (prefix-p "LEM" 142 | (package-name x))) 143 | (list-all-packages))) 144 | ;;;FIXME::see cepl.examples/cleanup for similar code 145 | #+nil 146 | (setf *packages* (find-lem-package)) 147 | (defun find-variables (&optional (packages *packages*)) 148 | (let ((acc nil)) 149 | (dolist (package packages) 150 | (do-symbols (sym package) 151 | (when (boundp sym) 152 | (when (eq (symbol-package sym) 153 | package) 154 | (push sym acc))))) 155 | acc)) 156 | (defun prefix-p (prefix string) 157 | "test whether prefix is a prefix of string" 158 | (let ((len (length prefix))) 159 | (search prefix string 160 | :start1 0 :end1 len 161 | :start2 0 :end2 (min len (length string)))))) 162 | -------------------------------------------------------------------------------- /keys.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lem-sucle) 2 | 3 | (defparameter *keycodes2* (make-hash-table)) 4 | (defun define-key-code (sym &optional glfw3-code) 5 | (setf (gethash glfw3-code *keycodes2*) 6 | sym)) 7 | (defun get-sym-from-glfw3-code (code) 8 | (gethash code *keycodes2*)) 9 | 10 | (defvar *keycode-table* (make-hash-table)) 11 | (defvar *keyname-table* (make-hash-table :test 'equal)) 12 | (defun defkeycode (name code &optional key) 13 | (setf (gethash name *keyname-table*) code) 14 | (when key (setf (gethash code *keycode-table*) key))) 15 | (defun get-code (name) 16 | (let ((code (gethash name *keyname-table*))) 17 | (assert code) 18 | code)) 19 | (defun char-to-key (char) 20 | (or (gethash (char-code char) *keycode-table*) 21 | (lem:make-key :sym (string char)))) 22 | (defun code-to-key (code) 23 | (or (gethash code *keycode-table*) 24 | (lem:make-key :sym (string (code-char code))))) 25 | (defun get-key-from-name (name) 26 | (char-to-key (code-char (get-code name)))) 27 | 28 | (progn 29 | (defkeycode "C-@" 0 (lem:make-key :ctrl t :sym "@")) 30 | (defkeycode "C-a" 1 (lem:make-key :ctrl t :sym "a")) 31 | (defkeycode "C-b" 2 (lem:make-key :ctrl t :sym "b")) 32 | (defkeycode "C-c" 3 (lem:make-key :ctrl t :sym "c")) 33 | (defkeycode "C-d" 4 (lem:make-key :ctrl t :sym "d")) 34 | (defkeycode "C-e" 5 (lem:make-key :ctrl t :sym "e")) 35 | (defkeycode "C-f" 6 (lem:make-key :ctrl t :sym "f")) 36 | (defkeycode "C-g" 7 (lem:make-key :ctrl t :sym "g")) 37 | (defkeycode "C-h" 8 (lem:make-key :ctrl t :sym "h"))) 38 | ;;#+nil 39 | (defkeycode "C-i" 9 (lem:make-key :sym "Tab")) 40 | (define-key-code "Tab" :tab) 41 | ;;#+nil 42 | (progn 43 | (defkeycode "C-j" 10 (lem:make-key :ctrl t :sym "j")) 44 | (defkeycode "C-k" 11 (lem:make-key :ctrl t :sym "k")) 45 | (defkeycode "C-l" 12 (lem:make-key :ctrl t :sym "l"))) 46 | ;;#+nil 47 | (defkeycode "C-m" 13 (lem:make-key :sym "Return")) 48 | ;;FIXME:: is enter 10 or 13? have multiple keys like keypad? 49 | (define-key-code "Return" :enter) 50 | ;;#+nil 51 | (progn 52 | (defkeycode "C-n" 14 (lem:make-key :ctrl t :sym "n")) 53 | (defkeycode "C-o" 15 (lem:make-key :ctrl t :sym "o")) 54 | (defkeycode "C-p" 16 (lem:make-key :ctrl t :sym "p")) 55 | (defkeycode "C-q" 17 (lem:make-key :ctrl t :sym "q")) 56 | (defkeycode "C-r" 18 (lem:make-key :ctrl t :sym "r")) 57 | (defkeycode "C-s" 19 (lem:make-key :ctrl t :sym "s")) 58 | (defkeycode "C-t" 20 (lem:make-key :ctrl t :sym "t")) 59 | (defkeycode "C-u" 21 (lem:make-key :ctrl t :sym "u")) 60 | (defkeycode "C-v" 22 (lem:make-key :ctrl t :sym "v")) 61 | (defkeycode "C-w" 23 (lem:make-key :ctrl t :sym "w")) 62 | (defkeycode "C-x" 24 (lem:make-key :ctrl t :sym "x")) 63 | (defkeycode "C-y" 25 (lem:make-key :ctrl t :sym "y")) 64 | (defkeycode "C-z" 26 (lem:make-key :ctrl t :sym "z"))) 65 | ;;#+nil 66 | (defkeycode "escape" 27 (lem:make-key :sym "Escape")) 67 | (define-key-code "Escape" :escape) ;;fixme:: not found? 68 | ;;#+nil 69 | (progn 70 | (defkeycode "C-\\" 28 (lem:make-key :ctrl t :sym "\\")) 71 | (defkeycode "C-]" 29 (lem:make-key :ctrl t :sym "]")) 72 | (defkeycode "C-^" 30 (lem:make-key :ctrl t :sym "^")) 73 | (defkeycode "C-_" 31 (lem:make-key :ctrl t :sym "_"))) 74 | #+nil 75 | (defkeycode "Spc" #x20 (lem:make-key :sym "Space")) 76 | (define-key-code "Space" :space) 77 | #+nil 78 | (defkeycode "[backspace]" #x7F (lem:make-key :sym "Backspace")) 79 | (define-key-code "Backspace" :backspace) 80 | 81 | ;;#+nil ;;FIXME -> character keys 82 | (loop :for code :from #x21 :below #x7F 83 | :do (let ((string (string (code-char code)))) 84 | (defkeycode string code (lem:make-key :sym string)))) 85 | #+nil 86 | (defkeycode "[down]" #o402 (lem:make-key :sym "Down")) 87 | (define-key-code "Down" :down) 88 | #+nil 89 | (defkeycode "[up]" #o403 (lem:make-key :sym "Up")) 90 | (define-key-code "Up" :up) 91 | #+nil 92 | (defkeycode "[left]" #o404 (lem:make-key :sym "Left")) 93 | (define-key-code "Left" :left) 94 | #+nil 95 | (defkeycode "[right]" #o405 (lem:make-key :sym "Right")) 96 | (define-key-code "Right" :right) 97 | #+nil 98 | (progn 99 | (defkeycode "C-down" 525 (lem:make-key :ctrl t :sym "Down")) 100 | (defkeycode "C-up" 566 (lem:make-key :ctrl t :sym "Up")) 101 | (defkeycode "C-left" 545 (lem:make-key :ctrl t :sym "Left")) 102 | (defkeycode "C-right" 560 (lem:make-key :ctrl t :sym "Right"))) 103 | #+nil 104 | (defkeycode "[home]" #o406 (lem:make-key :sym "Home")) 105 | (define-key-code "Home" :home) 106 | #+nil 107 | (defkeycode "[backspace]" #o407 (lem:make-key :sym "Backspace")) 108 | #+nil 109 | (defkeycode "[f0]" #o410 (lem:make-key :sym "F0")) 110 | #+nil 111 | (progn 112 | (defkeycode "[f1]" #o411 (lem:make-key :sym "F1")) 113 | (defkeycode "[f2]" #o412 (lem:make-key :sym "F2")) 114 | (defkeycode "[f3]" #o413 (lem:make-key :sym "F3")) 115 | (defkeycode "[f4]" #o414 (lem:make-key :sym "F4")) 116 | (defkeycode "[f5]" #o415 (lem:make-key :sym "F5")) 117 | (defkeycode "[f6]" #o416 (lem:make-key :sym "F6")) 118 | (defkeycode "[f7]" #o417 (lem:make-key :sym "F7")) 119 | (defkeycode "[f8]" #o420 (lem:make-key :sym "F8")) 120 | (defkeycode "[f9]" #o421 (lem:make-key :sym "F9")) 121 | (defkeycode "[f10]" #o422 (lem:make-key :sym "F10")) 122 | (defkeycode "[f11]" #o423 (lem:make-key :sym "F11")) 123 | (defkeycode "[f12]" #o424 (lem:make-key :sym "F12"))) 124 | (define-key-code "F1" :f1) 125 | (define-key-code "F2" :f2) 126 | (define-key-code "F3" :f3) 127 | (define-key-code "F4" :f4) 128 | (define-key-code "F5" :f5) 129 | (define-key-code "F6" :f6) 130 | (define-key-code "F7" :f7) 131 | (define-key-code "F8" :f8) 132 | (define-key-code "F9" :f9) 133 | (define-key-code "F10" :f10) 134 | (define-key-code "F11" :f11) 135 | (define-key-code "F12" :f12) 136 | #+nil 137 | (progn 138 | (defkeycode "[sf1]" #o425 (lem:make-key :shift t :sym "F1")) 139 | (defkeycode "[sf2]" #o426 (lem:make-key :shift t :sym "F2")) 140 | (defkeycode "[sf3]" #o427 (lem:make-key :shift t :sym "F3")) 141 | (defkeycode "[sf4]" #o430 (lem:make-key :shift t :sym "F4")) 142 | (defkeycode "[sf5]" #o431 (lem:make-key :shift t :sym "F5")) 143 | (defkeycode "[sf6]" #o432 (lem:make-key :shift t :sym "F6")) 144 | (defkeycode "[sf7]" #o433 (lem:make-key :shift t :sym "F7")) 145 | (defkeycode "[sf8]" #o434 (lem:make-key :shift t :sym "F8")) 146 | (defkeycode "[sf9]" #o435 (lem:make-key :shift t :sym "F9")) 147 | (defkeycode "[sf10]" #o436 (lem:make-key :shift t :sym "F10")) 148 | (defkeycode "[sf11]" #o437 (lem:make-key :shift t :sym "F11")) 149 | (defkeycode "[sf12]" #o440 (lem:make-key :shift t :sym "F12")) 150 | (defkeycode "[dl]" #o510) 151 | (defkeycode "[il]" #o511)) 152 | #+nil 153 | (defkeycode "[dc]" #o512 (lem:make-key :sym "Delete")) 154 | (define-key-code "Delete" :delete) 155 | #+nil 156 | (progn 157 | (defkeycode "C-dc" 519 (lem:make-key :ctrl t :sym "Delete")) 158 | (defkeycode "[ic]" #o513) 159 | (defkeycode "[eic]" #o514) 160 | (defkeycode "[clear]" #o515) 161 | (defkeycode "[eos]" #o516) 162 | (defkeycode "[eol]" #o517) 163 | (defkeycode "[sf]" #o520 (lem:make-key :shift t :sym "Down")) 164 | (defkeycode "[sr]" #o521 (lem:make-key :shift t :sym "Up"))) 165 | #+nil 166 | (defkeycode "[npage]" #o522 (lem:make-key :sym "PageDown")) 167 | (define-key-code "PageDown" :page-down) 168 | #+nil 169 | (defkeycode "[ppage]" #o523 (lem:make-key :sym "PageUp")) 170 | (define-key-code "PageUp" :page-up) 171 | #+nil 172 | (progn 173 | (defkeycode "[stab]" #o524) 174 | (defkeycode "[ctab]" #o525) 175 | (defkeycode "[catab]" #o526) 176 | (defkeycode "[enter]" #o527) 177 | (defkeycode "[print]" #o532) 178 | (defkeycode "[ll]" #o533) 179 | (defkeycode "[a1]" #o534) 180 | (defkeycode "[a3]" #o535) 181 | (defkeycode "[b2]" #o536) 182 | (defkeycode "[c1]" #o537) 183 | (defkeycode "[c3]" #o540) 184 | (defkeycode "[btab]" #o541 (lem:make-key :shift t :sym "Tab")) 185 | (defkeycode "[beg]" #o542) 186 | (defkeycode "[cancel]" #o543) 187 | (defkeycode "[close]" #o544) 188 | (defkeycode "[command]" #o545) 189 | (defkeycode "[copy]" #o546) 190 | (defkeycode "[create]" #o547)) 191 | #+nil 192 | (defkeycode "[end]" #o550 (lem:make-key :sym "End")) 193 | (define-key-code "End" :end) 194 | #+nil 195 | (progn 196 | (defkeycode "[exit]" #o551) 197 | (defkeycode "[find]" #o552) 198 | (defkeycode "[help]" #o553) 199 | (defkeycode "[mark]" #o554) 200 | (defkeycode "[message]" #o555) 201 | (defkeycode "[move]" #o556) 202 | (defkeycode "[next]" #o557) 203 | (defkeycode "[open]" #o560) 204 | (defkeycode "[options]" #o561) 205 | (defkeycode "[previous]" #o562) 206 | (defkeycode "[redo]" #o563) 207 | (defkeycode "[reference]" #o564) 208 | (defkeycode "[refresh]" #o565) 209 | (defkeycode "[replace]" #o566) 210 | (defkeycode "[restart]" #o567) 211 | (defkeycode "[resume]" #o570) 212 | (defkeycode "[save]" #o571) 213 | (defkeycode "[sbeg]" #o572) 214 | (defkeycode "[scancel]" #o573) 215 | (defkeycode "[scommand]" #o574) 216 | (defkeycode "[scopy]" #o575) 217 | (defkeycode "[screate]" #o576) 218 | (defkeycode "[sdc]" #o577 (lem:make-key :shift t :sym "Delete")) 219 | (defkeycode "[sdl]" #o600) 220 | (defkeycode "[select]" #o601) 221 | (defkeycode "[send]" #o602 (lem:make-key :shift t :sym "End")) 222 | (defkeycode "[seol]" #o603) 223 | (defkeycode "[sexit]" #o604) 224 | (defkeycode "[sfind]" #o605) 225 | (defkeycode "[shelp]" #o606) 226 | (defkeycode "[shome]" #o607 (lem:make-key :shift t :sym "Home")) 227 | (defkeycode "[sic]" #o610) 228 | (defkeycode "[sleft]" #o611 (lem:make-key :shift t :sym "Left")) 229 | (defkeycode "[smessage]" #o612) 230 | (defkeycode "[smove]" #o613) 231 | (defkeycode "[snext]" #o614 (lem:make-key :shift t :sym "PageDown")) 232 | (defkeycode "[soptions]" #o615) 233 | (defkeycode "[sprevious]" #o616 (lem:make-key :shift t :sym "PageUp")) 234 | (defkeycode "[sprint]" #o617) 235 | (defkeycode "[sredo]" #o620) 236 | (defkeycode "[sreplace]" #o621) 237 | (defkeycode "[sright]" #o622 (lem:make-key :shift t :sym "Right")) 238 | (defkeycode "[srsume]" #o623) 239 | (defkeycode "[ssave]" #o624) 240 | (defkeycode "[ssuspend]" #o625) 241 | (defkeycode "[sundo]" #o626) 242 | (defkeycode "[suspend]" #o627) 243 | (defkeycode "[undo]" #o630) 244 | (defkeycode "[mouse]" #o631) 245 | (defkeycode "[resize]" #o632) 246 | (defkeycode "[event]" #o633)) 247 | -------------------------------------------------------------------------------- /sucle.lisp: -------------------------------------------------------------------------------- 1 | (in-package :lem-sucle) 2 | 3 | (defparameter *saved-session* nil) 4 | (defun input-loop (&optional (editor-thread lem-sucle::*editor-thread*)) 5 | (setf application::*main-subthread-p* nil) 6 | (destructuring-bind (width height) (window-size) 7 | (application::main 8 | (lambda () 9 | (init) 10 | (block out 11 | (handler-case 12 | (let ((out-token (list "good" "bye"))) 13 | (catch out-token 14 | (loop 15 | (livesupport:update-repl-link) 16 | (livesupport:continuable 17 | (per-frame editor-thread out-token))))) 18 | (exit-editor (c) (return-from out c))))) 19 | :width width 20 | :height height 21 | :title "lem is an editor for Common Lisp" 22 | :resizable t))) 23 | 24 | 25 | (defparameter *last-scroll* 0) 26 | (defparameter *scroll-difference* 0) 27 | (defparameter *scroll-speed* 5) 28 | (defparameter *run-sucle* nil) 29 | (defun per-frame (editor-thread out-token) 30 | (declare (ignorable editor-thread)) 31 | (application::on-session-change *saved-session* 32 | (window::set-vsync t)) 33 | (application:poll-app) 34 | (when *run-sucle* 35 | (unwind-protect 36 | (application::with-quit-token () 37 | (funcall sucle::*sucle-app-function*)) 38 | (setf *run-sucle* nil) 39 | (window:get-mouse-out))) 40 | (let ((newscroll (floor window::*scroll-y*))) 41 | (setf *scroll-difference* (- newscroll *last-scroll*)) 42 | (setf *last-scroll* newscroll)) 43 | 44 | (handler-case 45 | (progn 46 | (when window::*status* 47 | ;;(bt:thread-alive-p editor-thread) 48 | (throw out-token nil)) 49 | (when *resized-p* 50 | (setf *resized-p* nil) 51 | (lem:send-event :resize)) 52 | (scroll-event) 53 | (input-events) 54 | ;;#+nil 55 | (calculate-cursor-coordinate) 56 | (handle-dropped-files) 57 | (left-click-event) 58 | #+nil 59 | (let ((event)) 60 | 61 | (if (eq event :abort) 62 | (send-abort-event editor-thread nil) 63 | ;;(send-event event) 64 | ))) 65 | #+nil 66 | #+sbcl 67 | (sb-sys:interactive-interrupt (c) 68 | (declare (ignore c)) 69 | (lem:send-abort-event editor-thread t))) 70 | 71 | ;;Flush the changes made to the ncurses-clone display 72 | (when *redraw-display-p* 73 | (setf *redraw-display-p* nil) 74 | (lem:redraw-display)) 75 | 76 | ;;Rendering. Comes after input handling because things could have changed 77 | (render 78 | :ondraw 79 | (lambda () 80 | ;;Set the title of the window to the name of the current buffer 81 | (window:set-caption (lem-base:buffer-name (lem:current-buffer))) 82 | (setf *some-data* nil) 83 | #+nil 84 | (clrhash *some-data*)) 85 | :big-glyph-fun 86 | 'save-special-glyphs 87 | )) 88 | (defparameter *some-data* 89 | nil 90 | ;;(make-hash-table :test 'eq) 91 | ) 92 | 93 | 94 | (defun save-special-glyphs (glyph) 95 | (let ((data (ncurses-clone::extra-big-glyph-attribute-data glyph))) 96 | (destructuring-bind (attribute view) data 97 | (let ((window (ncurses-clone-lem-view:ncurses-view-parent-window 98 | view)) 99 | (overlay (sucle-attribute-overlay attribute))) 100 | (push glyph (getf (getf *some-data* window) overlay)) 101 | #+nil 102 | (multiple-value-bind (overlay-hash existsp) 103 | (unless existsp 104 | (let ((value (make-hash-table :test 'eq))) 105 | (setf (gethash window *some-data*) 106 | value) 107 | (setf overlay-hash value)))) 108 | #+nil 109 | (when (zerop (random 200)) 110 | (print (list 111 | window 112 | overlay 113 | attribute 114 | x y))))))) 115 | 116 | (defparameter *output* *standard-output*) 117 | (defparameter *mouse-last-position* nil) 118 | 119 | (defparameter *mouse-mode* nil) 120 | 121 | (defun reset-mouse-mode () 122 | (setf *mouse-mode* nil)) 123 | 124 | (defun same-buffer-points (a b) 125 | (eq 126 | (lem:point-buffer a) 127 | (lem:point-buffer b))) 128 | 129 | (defparameter *grid-mouse-x* nil) 130 | (defparameter *grid-mouse-y* nil) 131 | (defun calculate-cursor-coordinate () 132 | ;;For some reason, the coordinate of the mouse is off by 1,1? 133 | (setf *grid-mouse-x* 134 | (floor (- window::*mouse-x* 1) 135 | *glyph-width*)) 136 | (setf *grid-mouse-y* 137 | (floor (- 138 | window::*mouse-y* 139 | ;;There's a little space between the edge of the window and the area lem uses, 140 | ;;since the window coordinates are not necessary multiples of the glyph size 141 | ;;This causes the y position of the cursor to become messed up, if not accounted for 142 | (mod window::*height* 143 | *glyph-height*) 144 | 1) 145 | *glyph-height*))) 146 | 147 | (struct-to-clos:struct->class 148 | (defstruct window-intersection 149 | window 150 | intersection-type)) 151 | 152 | (defparameter *null-window-intersection* (make-window-intersection)) 153 | (defparameter *window-last-clicked-at* *null-window-intersection*) 154 | (defun clear-window-intersection () 155 | (setf *window-last-clicked-at* *null-window-intersection*)) 156 | (defun left-click-event () 157 | (let ((just-pressed (window:button :mouse :pressed :left window::*control-state*)) 158 | (just-released (window:button :mouse :released :left window::*control-state*)) 159 | (pressing (window:button :mouse :down :left window::*control-state*))) 160 | (let* ((coord (list *grid-mouse-x* *grid-mouse-y*)) 161 | (coord-change 162 | (not (equal coord 163 | *mouse-last-position*)))) 164 | ;;FIXME::better logic? comments? 165 | ;;TODO::handle selections across multiple windows? 166 | (when just-pressed 167 | ;;(print "cancelling") 168 | (multiple-value-bind (window intersection-type) 169 | (detect-mouse-window-intersection) 170 | ;;reset the mouse mode before, not after because 171 | ;;the intersection type can decide the mode 172 | (case *mouse-mode* 173 | ((:drag-resize-window :marking) (reset-mouse-mode))) 174 | (if (null intersection-type) 175 | (clear-window-intersection) 176 | (let ((intersection-data 177 | (make-window-intersection :window window 178 | :intersection-type intersection-type))) 179 | (setf *window-last-clicked-at* intersection-data) 180 | (setf (lem:current-window) window) 181 | (case intersection-type 182 | (:center 183 | (move-window-cursor-to-mouse window)) 184 | ((:vertical :horizontal) 185 | (setf *mouse-mode* :drag-resize-window))) 186 | (redraw-display)))) 187 | (handle-multi-click coord) 188 | (handle-multi-click-selection)) 189 | (let ((window (window-intersection-window *window-last-clicked-at*))) 190 | (when (and pressing 191 | window) 192 | (ecase (window-intersection-intersection-type *window-last-clicked-at*) 193 | (:center 194 | (let ((y (- *grid-mouse-y* 195 | (lem:window-y window) ;;is move-window-cursor-to-mouse redundant? 196 | ))) 197 | (let ((scroll-down-offset 198 | (cond 199 | ((> 0 y) 200 | y) 201 | ((>= y (rectified-window-height window)) 202 | (+ 1 (- y (rectified-window-height window)))) 203 | (t 0)))) 204 | (when (or 205 | ;;when scrolled by mouse 206 | (not (zerop *scroll-difference*)) 207 | ;;when it is scrolled 208 | (not (zerop scroll-down-offset)) 209 | ;;when its dragging 210 | coord-change) 211 | (lem:scroll-down scroll-down-offset) 212 | (move-window-cursor-to-mouse window 213 | *grid-mouse-x* 214 | (- *grid-mouse-y* scroll-down-offset)) 215 | (redraw-display))))) 216 | (:horizontal 217 | (handler-case 218 | (let* ((p1 (window-horizontal-edge-coord window)) 219 | (p2 *grid-mouse-x*) 220 | (difference (- p2 p1))) 221 | (unless (zerop difference) 222 | (reorder-window-tree) 223 | (if (plusp difference) 224 | (dotimes (i difference) 225 | (lem:grow-window-horizontally 1)) 226 | (dotimes (i (- difference)) 227 | (lem:shrink-window-horizontally 1))) 228 | (redraw-display))) 229 | (lem:editor-error (c) 230 | (declare (ignorable c))))) 231 | (:vertical 232 | (handler-case 233 | (let* ((p1 (window-vertical-edge-coord window)) 234 | (p2 *grid-mouse-y*) 235 | (difference (- p2 p1))) 236 | (unless (zerop difference) 237 | (reorder-window-tree) 238 | (if (plusp difference) 239 | (dotimes (i difference) 240 | (lem:grow-window 1)) 241 | (dotimes (i (- difference)) 242 | (lem:shrink-window 1))) 243 | (redraw-display))) 244 | (lem:editor-error (c) 245 | (declare (ignorable c)))))))) 246 | (when just-released 247 | (case *mouse-mode* 248 | ((:marking :drag-resize-window) (reset-mouse-mode)))) 249 | (handle-drag-select-region pressing just-pressed) 250 | ;;save the mouse position for next tick 251 | (setf *mouse-last-position* coord)))) 252 | 253 | (defun reorder-window-tree (&optional (window-tree (lem::window-tree))) 254 | (labels ((f (tree) 255 | (cond ((lem::window-tree-leaf-p tree) 256 | ;;(funcall fn tree) 257 | ) 258 | (t 259 | (one-swap-window tree) 260 | (f (lem::window-node-car tree)) 261 | (f (lem::window-node-cdr tree)))))) 262 | (f window-tree) 263 | (values))) 264 | 265 | (defun one-swap-window (instance) 266 | (let ((car (lem::window-node-car instance))) 267 | (when (and (lem::window-node-p car) 268 | (eq (lem::window-node-split-type car) 269 | (lem::window-node-split-type instance))) 270 | ;;(print "reordering windows") 271 | (let ((a (lem::window-node-car car)) 272 | (b (lem::window-node-cdr car)) 273 | (c (lem::window-node-cdr instance))) 274 | (setf (lem::window-node-car instance) a) 275 | (setf (lem::window-node-cdr instance) car) 276 | (setf (lem::window-node-car car) b) 277 | (setf (lem::window-node-cdr car) c))))) 278 | 279 | (defun safe-point= (point-a point-b) 280 | (and 281 | ;;make sure they are in the same buffer 282 | (same-buffer-points point-a point-b) 283 | ;;then check whether they are equal 284 | (lem:point= point-a point-b))) 285 | 286 | (defparameter *point-at-last* nil) 287 | (defun handle-drag-select-region (pressing just-pressed) 288 | (let* ((last-point *point-at-last*) 289 | (point (lem:current-point)) 290 | (point-coord-change 291 | (not (and 292 | ;;it exists 293 | *point-at-last* 294 | ;;its the same position as point 295 | (safe-point= *point-at-last* point))))) 296 | (when point-coord-change 297 | (setf *point-at-last* 298 | (lem:copy-point point 299 | :temporary))) 300 | (when (and 301 | pressing 302 | (null *mouse-mode*) 303 | ;;if it was just pressed, there's going to be a point-coord jump 304 | (not just-pressed) 305 | ;;selecting a single char should not start marking 306 | point-coord-change) 307 | ;;beginning to mark 308 | (let ((current-point (lem:current-point))) 309 | (if (and 310 | last-point 311 | (same-buffer-points current-point last-point)) 312 | (progn 313 | (lem:set-current-mark last-point)) 314 | (progn 315 | ;;(print "234234") 316 | ;;FIXME? when does this happen? when the last point is null or 317 | ;;exists in a different buffer? allow buffer-dependent selection? 318 | (lem:set-current-mark current-point)))) 319 | (setf *mouse-mode* :marking)))) 320 | 321 | (defun handle-dropped-files () 322 | ;;switch to window that the mouse is hovering over, and find that file 323 | (when window::*dropped-files* 324 | (let ((window 325 | (detect-mouse-window-intersection))) 326 | (when window 327 | (setf (lem:current-window) window))) 328 | (unless 329 | ;;Do not drop a file into the minibuffer 330 | (eq lem::*minibuf-window* 331 | (lem:current-window)) 332 | (dolist (file window::*dropped-files*) 333 | (lem:find-file file)) 334 | (redraw-display)))) 335 | 336 | (defparameter *last-clicked-at* nil) ;;to detect double and triple clicks etc... 337 | (defparameter *clicked-at-times* 0) 338 | (defun handle-multi-click (coord) 339 | (if (equal *last-clicked-at* coord) 340 | (incf *clicked-at-times*) 341 | (progn 342 | (setf *last-clicked-at* coord) 343 | (setf *clicked-at-times* 1)))) 344 | 345 | (defparameter *point-clicked-at* nil) ;;point representing the starting location in the buffer 346 | (defparameter *click-selection-count* 0) 347 | ;;the number of times clicks consecutively at a position, 348 | ;;starting with 1 349 | (defun handle-multi-click-selection () 350 | (flet ((cancel-click-selection () 351 | (lem:buffer-mark-cancel (lem:current-buffer)) 352 | (setf *click-selection-count* 0))) 353 | (cond 354 | ((= 1 *clicked-at-times*) 355 | (cancel-click-selection) 356 | (setf *point-clicked-at* 357 | (lem:copy-point (lem:current-point) 358 | :temporary))) 359 | ((< 1 *clicked-at-times*) 360 | ;;(print *clicked-at-times*) 361 | 362 | ;;(lem:save-excursion) 363 | (let ((successp t)) 364 | (incf *click-selection-count*) 365 | (let (inside 366 | (on-last-paren nil)) 367 | (lem:with-point ((start *point-clicked-at*) 368 | (end *point-clicked-at*)) 369 | (handler-case (progn 370 | (lem:move-point (lem:current-point) *point-clicked-at*) 371 | (lem:forward-sexp) ;;fails if on a closing paren 372 | (lem:move-point end (lem:current-point)) 373 | (lem:backward-sexp) ;;fails at first char in list 374 | (lem:move-point start (lem:current-point)) 375 | (setf inside 376 | (and (lem:point<= start *point-clicked-at*) 377 | (lem:point< *point-clicked-at* end)))) 378 | (lem:editor-error (c) 379 | (declare (ignorable c)) 380 | (setf on-last-paren t))) 381 | (let ((iteration-count *click-selection-count*)) 382 | ;;(print (list inside on-last-paren)) 383 | (when inside 384 | (decf iteration-count)) 385 | (dotimes (i iteration-count) 386 | (handler-case (progn 387 | ;;(lem:save-excursion 388 | (lem:backward-up-list) 389 | ) 390 | (lem:editor-error (c) 391 | (declare (ignorable c)) 392 | ;;turn this on to select the whole buffer 393 | ;;(lem::mark-set-whole-buffer) 394 | (setf successp nil))))) 395 | (if successp 396 | (progn 397 | ;;(lem:move-point (lem:current-point) start) 398 | (lem:set-current-mark (lem:copy-point (lem:current-point) 399 | :temporary)) 400 | (lem:mark-sexp)) 401 | (progn (cancel-click-selection) 402 | (lem:move-point (lem:current-point) 403 | *point-clicked-at*)))))))))) 404 | 405 | (defun move-window-cursor-to-mouse (window &optional (x1 *grid-mouse-x*) (y1 *grid-mouse-y*)) 406 | (let ((x (lem:window-x window)) 407 | (y (lem:window-y window))) 408 | (mouse-move-to-cursor window (- x1 x) (- y1 y)))) 409 | 410 | (defun mouse-move-to-cursor (window x y) 411 | (let ((point (lem:current-point)) 412 | (view-point (lem::window-view-point window))) 413 | ;;view-point is in the very upper right 414 | (when (same-buffer-points point view-point) 415 | (lem:move-point point view-point) 416 | (lem:move-to-next-virtual-line point y) 417 | (lem:move-to-virtual-line-column point x)))) 418 | #+nil 419 | (defun mouse-get-window-rect (window) 420 | (values (lem:window-x window) 421 | (lem:window-y window) 422 | (lem:window-width window) 423 | (lem:window-height window))) 424 | 425 | (defun horizontally-between (window &optional (x1 *grid-mouse-x*)) 426 | (let ((x (lem:window-x window)) 427 | (w (lem:window-width window))) 428 | (and (<= x x1) (< x1 (+ x w))))) 429 | (defun rectified-window-height (window) 430 | (+ (lem::window-height window) 431 | (if (lem::window-use-modeline-p window) 432 | -1 433 | 0))) 434 | 435 | (defun vertically-between (window &optional (y1 *grid-mouse-y*)) 436 | (let ((y (lem:window-y window))) 437 | (and (<= y y1) 438 | (< y1 439 | (+ y (rectified-window-height window)))))) 440 | (defun centered-between (window &optional (x1 *grid-mouse-x*) (y1 *grid-mouse-y*)) 441 | (and (horizontally-between window x1) 442 | (vertically-between window y1))) 443 | (defun window-vertical-edge-coord (window) 444 | #+nil 445 | (- (lem:window-y window) 1) 446 | (+ (lem:window-y window) 447 | (rectified-window-height window))) 448 | 449 | (defun window-horizontal-edge-coord (window) 450 | #+nil 451 | (- (lem:window-x window) 1) 452 | (+ (lem:window-x window) 453 | (lem:window-width window))) 454 | 455 | (defun detect-mouse-window-intersection 456 | (&optional (x1 *grid-mouse-x*) (y1 *grid-mouse-y*) 457 | ;; &optional (press nil) 458 | ) 459 | ;;find the window which the coordinates x1 and y1 intersect at and return the window 460 | ;;and intersection type 461 | ;;returns (values window[if found window, otherwise nil] intersection-type) 462 | ;;intersection is one of :vertical, :horizontal, :center, or nil 463 | (let ((windows (lem:window-list))) 464 | #+nil;;FIXME::what does this variable do in lem? 465 | (when lem::*minibuffer-calls-window* 466 | (push lem::*minibuffer-calls-window* windows)) 467 | (when lem::*minibuf-window* 468 | (push lem::*minibuf-window* windows)) 469 | (block return 470 | (dolist (window windows) 471 | #+nil 472 | (when (eq window lem::*minibuf-window*) 473 | ;;(print (list x y w h x1 y1)) 474 | ) 475 | (cond 476 | ;; vertical dragging window 477 | ((and (= y1 (window-vertical-edge-coord window)) 478 | (horizontally-between window x1)) 479 | ;;(setf *dragging-window* (list window 'y)) 480 | (return-from return (values window :vertical))) 481 | ;; horizontal dragging window 482 | ((and (= x1 (window-horizontal-edge-coord window)) 483 | (vertically-between window y1)) 484 | ;;(setf *dragging-window* (list window 'x)) 485 | (return-from return (values window :horizontal))) 486 | ((centered-between window x1 y1) 487 | (return-from return (values window :center))) 488 | (t))) 489 | (values nil nil)))) 490 | 491 | (defun scroll-event () 492 | ;;scrolling 493 | (let ((scroll *scroll-difference*)) 494 | (unless (zerop scroll) 495 | (lem:scroll-up (* *scroll-speed* scroll)) 496 | (redraw-display) 497 | ))) 498 | (defun input-events () 499 | ;;(print (list window::*control* window::*alt* window::*super*)) 500 | ;;unicode input 501 | (dolist (press window::*char-keys*) 502 | (destructuring-bind (byte mods) press 503 | (let ((key (code-to-key byte))) 504 | (unless 505 | ;;FIXME::better logic to handle this? ;;This is because space gets sent twice, 506 | ;;once as a unicode char and once as a control key. The control key is for 507 | ;;exampe C-Space 508 | (member byte (load-time-value (list (char-code #\Space)))) 509 | (lem:send-event 510 | (lem:make-key 511 | :sym (lem:key-sym key) 512 | :ctrl (or (lem:key-ctrl key) 513 | (logtest window::+control+ mods) 514 | (window:button :key :down :escape) 515 | ;;FIXME:: escape used as substitute for control, specifically windows. 516 | ;;see below for same info. 517 | ) 518 | :shift (or (lem:key-shift key) 519 | ;;window::*shift* ;;FIXME::why is this here? 520 | ) 521 | :meta (or (lem:key-meta key) 522 | (logtest window::+alt+ mods)) 523 | :super (or (lem:key-super key) 524 | (logtest window::+super+ mods)))))))) 525 | ;;control key input, such as Tab, delete, enter 526 | (let ((array (window::control-state-jp-or-repeat window::*control-state*))) 527 | (declare (type window::mouse-keyboard-input-array array)) 528 | (dotimes (code 128) 529 | (let ((true-p (= 1 (sbit array code)))) 530 | (when true-p 531 | (multiple-value-bind (name type) (window::back-value code) 532 | ;;(print (list name type)) 533 | (case type 534 | (:key ;;FIXME::add mouse support? 535 | (cond ((and (window::character-key-p code) 536 | (not (member name '(:space)));;;FIXME::better logic to handle this? 537 | )) 538 | (t 539 | (if (member name 540 | '(:left-shift :left-control :left-super :left-alt 541 | :right-shift :right-control :right-super :right-alt 542 | :escape ;;FIXME::escape used as substitute for control, 543 | ;;specifically for windows 544 | )) 545 | ;;FIXME::more efficient test? 546 | nil ;;;ignore the modifier keys for shift, super, alt, control 547 | (let ((key (get-sym-from-glfw3-code name))) 548 | (if key 549 | (lem:send-event (lem:make-key 550 | :sym key 551 | :meta window::*alt* 552 | :super window::*super* 553 | :shift window::*shift* 554 | :ctrl window::*control*)) 555 | (format *error-output* 556 | "~s key unimplemented" name)))))))))))))) 557 | 558 | --------------------------------------------------------------------------------