;; Title:Love Ring Buffer
;; Description:A simple buffer that can be cut and paste into.
;; Author:AlexJGriffith
;; Email:griffitaj@gmail.com
;; Version:0.1

;;; Example:
;; (local ring-buffer (require :ring-buffer))
;; 
;; (fn love.load []
;;   (love.keyboard.setKeyRepeat true)
;;   (let [font (love.graphics.newFont :inconsolata.otf 24)]
;;     (set _G.buffer-1 (ring-buffer.new font []))))

;; (fn love.draw []
;;   (_G.buffer-1:draw))

;; (fn love.update [dt])

;; (fn love.keypressed [key scancode is-repeat]
;;   (_G.buffer-1:keypressed key _G.buffer-1.default-bindings))

;; (fn love.keyreleased [key scancode])

;; (fn love.textinput [key]
;;   (_G.buffer-1:textinput key _G.buffer-1.default-bindings))


;; (define-key fennel-mode-map (kbd "C-c C-z") (lambda () (interactive) (shell-command "kill $(ps aux | grep love-fennel | head -1 | awk '{print $2}')") (fennel-repl "love-fennel")))

(local ring-buffer {})

(fn ring-buffer.new [font styles]
  (setmetatable {:left [] :right [] : font  : styles :chord-key false :mark false}
                {:__index ring-buffer}))
  
(fn ring-buffer.insert [{: left : font} key]  
  (table.insert left [key (font:getWidth key) (font:getHeight key) 0]))

(fn ring-buffer.delete [{: left}] (table.remove left (# left)))

(fn ring-buffer.move-left [{: right : left}]
  (let [index (# left)]
    (table.insert right (. left index))
    (table.remove left index)
    ;; always return the value at current point, current position and
    ;; positions moved
    (values (. left (# left)) (# left) 1)))

(fn ring-buffer.move-left-n [rb n]
  (for [i 1 n] (rb:move-left)))

(fn ring-buffer.move-right [{: right : left}]
  (let [index (# right)]
    (table.insert left (. right index))
    (table.remove right index)
    (values (. left (# left)) (# left) 1)))

(fn ring-buffer.move-right-n [rb n]
  (for [i 1 n] (rb:move-right)))

(fn ring-buffer.move-up [rb]
  (let [previous-point (# rb.left)
        (_ _ column) (ring-buffer.move-line-start rb)]
    (if (~= 0 (# rb.left))
        (do (ring-buffer.move-left rb)
            (let [(_ _ column2) (ring-buffer.move-line-start rb)]
              (when (> (math.min column column2) 0)
                (ring-buffer.move-right-n rb (math.min column column2)))))
        (ring-buffer.goto-point rb previous-point)))
  (values (. rb.left (# rb.left)) (# rb.left) 1))

(fn ring-buffer.move-down [rb]
  (let [previous-point (# rb.left)
        (_ _ column) (ring-buffer.move-line-end rb)]
    (if (~= 0 (# rb.right))
        (do (ring-buffer.move-right rb)
            (let [(_ _ column2) (ring-buffer.move-line-end rb)]
              (when (> (math.min column column2) 0)
                (ring-buffer.move-left-n rb (math.min column column2)))))
        (ring-buffer.goto-point rb previous-point)))
  (values (. rb.left (# rb.left)) (# rb.left) 1))

(fn ring-buffer.move-start [{: right : left}]
  (let [len (# left)]
    (for [i 1 len]
      (let [j (+ 1 (- len i))]
        (table.insert right (. left j))
        (table.remove left j)))
    (values (. left (# left)) (# left) len)))

(fn ring-buffer.move-end [{: right : left}]
  (let [len (# right)]
    (for [i 1 len]
      (let [j (+ 1 (- len i))]
        (table.insert left (. right j))
        (table.remove right j)))
    (values (. left (# left)) (# left) len)))

(fn ring-buffer.move-line-start [{: right : left}]
  (let [len (# left)]
    (var char (. left (# left)))
    (var position-change 0)
    (while (and (> (# left) 0) char (~= (. char 1) "\n"))
      (set position-change (+ position-change 1))      
      (let [i position-change
            j (+ 1 (- len i))]
        (table.insert right (. left j))
        (table.remove left j))
      (set char (. left (# left))))
    (values (. left (# left)) (# left) position-change)))

(fn ring-buffer.move-line-end [{: right : left}]
  (let [len (# right)]
    (var char (. right (# right)))
    (var position-change 0)
    (while (and (> (# right) 0) char (~= (. char 1) "\n"))
      (set position-change (+ position-change 1))      
      (let [i position-change
            j (+ 1 (- len i))]
        (table.insert left (. right j))
        (table.remove right j))
      (set char (. right (# right))))
    (values (. left (# left)) (# left) position-change)))

(fn ring-buffer.goto-point [rb point]
  (let [mid (# rb.left)
        len (+ mid (# rb.right))]
    (if (<= point 0) (ring-buffer.move-start rb)
        (>= point len) (ring-buffer.move-end rb)
        (< point mid) (ring-buffer.move-left-n rb (- mid point))
        (> point mid) (ring-buffer.move-right-n rb (- point mid))
        (= point mid) (values (. rb.left mid) mid 0))))

(fn ring-buffer.within-marks [{: mark : left} point]
  (let [mid (# left)]
    (if (and mark (< mark mid)) (and (>= point mark) (< point mid))
        (and mark (> mark mid)) (and (> point mid) (<= point mark))
        false)))

(fn ring-buffer.kill-region [{: mark : left &as rb}]
  (let [mid (# left)]
    (if (and mark (< mark mid))
        (do (ring-buffer.goto-point rb mid)
            (set rb.mark false)
            (for [_i 1 (- mid mark)]
              (ring-buffer.delete rb)))
        (and mark (> mark mid))
        (do (ring-buffer.goto-point rb mark)
            (set rb.mark false)
            (for [_i 1 (- mark mid)]
              (ring-buffer.delete rb)))
        (ring-buffer.delete rb))))

(fn ring-buffer.copy-region [{: mark : left : right &as rb}]
  (fn sub [buffer start end]
    (var str "")
    (for [i start end]
      (when (. buffer i)
        (set str (.. str (. buffer i 1)))))
    str)
  (let [mid (# left)
        len (- mark mid)
        end (# right)
        substring (if (and mark (< mark mid)) (sub left mark mid)
                      (and mark (> mark mid))
                      (do (-> (sub right (- end len) end)
                              (string.reverse)))
                      "")]
    (set rb.mark false)
    (love.system.setClipboardText substring)))

(fn ring-buffer.cut-region [{: mark : left : right &as rb}]
  (let [mark rb.mark]
    (ring-buffer.copy-region rb)
    (set rb.mark mark)
    (ring-buffer.kill-region rb)))

(fn ring-buffer.paste [{: mark : left : right &as rb}]
  ;; Sample utf8 symbol:😊
  (when mark (ring-buffer.kill-region rb))
  (let [utf8 (require :utf8)
        text (love.system.getClipboardText)]
    (var i 1)
    (var start 1)
    (var end (utf8.offset text i))
    (while end
      (ring-buffer.insert rb (string.sub text start (- end 1)))
      (set start end)
      (set i (+ i 1))
      (set end (utf8.offset text i)))))

(fn ring-buffer.set-mark [rb]
  (set rb.mark (if rb.mark false (# rb.left))))

(fn ring-buffer.draw [{: right : left : font &as rb}]
  (local lg love.graphics)
  (lg.setColor 1 1 1 1)
  (lg.rectangle :fill 0 0 1000 1000)
  (lg.setColor 0 0 0 1)
  (lg.setFont font)
  (var row-width 0)
  (var point 0)
  (local h (font:getHeight left))
  (for [i 1 (# left)]
    (let [[char w] (. left i)]
      (match char 
        "\n"  (do
                (lg.translate (- row-width) h)
                (set row-width 0))
        _ (do
            (when (ring-buffer.within-marks rb point)
              (lg.setColor 0.9 0.9 0.9 1)
              (lg.rectangle :fill 0 0 w h)
              (lg.setColor 0 0 0 1))
            (lg.print char)
              ;; (lg.rectangle :line 0 0 w h)
              (set row-width (+ row-width w))
              (lg.translate w 0))))
    (set point (+ point 1)))
  (local w (font:getWidth " "))
  (lg.rectangle :fill 0 0 w h)
  (when (> (# right) 0)
    (for [j 1 (# right)]
      (local i (+ 1 (- (# right) j)))
      (if (= j 1)
          (lg.setColor 1 1 1 1)
          (lg.setColor 0 0 0 1))
      (let [[char w] (. right i)]
        (match char 
          "\n"  (do
                  (lg.translate (- row-width) h)
                  (set row-width 0)
                  )
          _ (do
              (when (ring-buffer.within-marks rb point)
                (lg.setColor 0.9 0.9 0.9 1)
                (lg.rectangle :fill 0 0 w h)
                (lg.setColor 0 0 0 1))
              (lg.print char)
              ;; (lg.rectangle :line 0 0 w h)
              (set row-width (+ row-width w))
              (lg.translate w 0)))
        (set point (+ point 1))))))

(fn ring-buffer.encode-chord [str ctrl meta shift]
  (.. (if ctrl "C-" "") (if meta "M-" "") (if shift "S-" "") str))

(fn ring-buffer.keypressed [rb key bindings]
  (fn binding-call [key bindings]
    (let [isDown love.keyboard.isDown
          chord (ring-buffer.encode-chord
                             key
                             (isDown "lctrl" "rctrl")
                             (isDown "lalt" "ralt")
                             (isDown "lshift" "rshift"))]
      (values (. bindings chord) chord)))
  (let [bc (binding-call key bindings)]
    (if bc
        (do (set rb.chord-key true) (bc rb key))
        (set rb.chord-key false))))

(fn ring-buffer.textinput [rb key bindings]
  (when (not rb.chord-key)
    (when rb.mark (rb:kill-region))
    (rb:insert key bindings)))

(set ring-buffer.emacs-bindings
     {:backspace (fn [rb key] (rb:kill-region))
      :return (fn [rb key] (rb:insert "\n"))
      :left (fn [rb key] (rb:move-left))
      :right (fn [rb key] (rb:move-right))
      :up (fn [rb key] (rb:move-up))
      :down (fn [rb key] (rb:move-down))
      "C-a" (fn [rb key] (rb:move-line-start))
      "C-e" (fn [rb key] (rb:move-line-end))
      "M-S-," (fn [rb key] (rb:move-start))
      "M-S-." (fn [rb key] (rb:move-end))
      "C-space" (fn [rb key] (rb:set-mark))
      "M-w" (fn [rb key] (rb:copy-region))
      "C-w" (fn [rb key] (rb:cut-region))
      "C-y" (fn [rb key] (rb:paste))
      })

(set ring-buffer.default-bindings
     {:backspace (fn [rb key] (rb:kill-region))
      :return (fn [rb key] (rb:insert "\n"))
      :left (fn [rb key] (rb:move-left))
      :right (fn [rb key] (rb:move-right))
      :up (fn [rb key] (rb:move-up))
      :down (fn [rb key] (rb:move-down))
      "home" (fn [rb key] (rb:move-line-start))
      "end" (fn [rb key] (rb:move-line-end))
      "C-space" (fn [rb key] (rb:set-mark))
      "C-c" (fn [rb key] (rb:copy-region))
      "C-x" (fn [rb key] (rb:cut-region))
      "C-v" (fn [rb key] (rb:paste))
      })

ring-buffer

Generated by alexjgriffith using scpaste at Fri Apr 5 17:16:16 2024. EDT. (original)