Ben / Nujel

(defclass TextBuffer
  "A buffer for text editors"
  :export

  (defn new (self filename)
        (def lines [(buffer/allocate 16)])
        { :lines lines
          :filename filename
          :changed #f
          :pos-x 0
          :pos-y 0
          :scroll-x 0
          :scroll-y 0
          :mark #nil
          :scroll-interval 20
          :prototype* self })

  (defn get-modeline (self)
        (def x self.pos-x)
        (def y (inc self.pos-y))
        (def bufname (:get-buf-name self))
        (def saved (if self.changed "*" ""))
        (fmt " L{y}:{x} - {bufname}"))

  (defn get-line (self line-y)
        (def lines self.lines)
        (if (or (< line-y 0)
                (>= line-y (:length lines)))
            #nil
            (ref lines line-y)))

  (defn line-length (self pos-y)
        (def line (:get-line self pos-y))
        (when-not line (return 0))
        (dotimes (i (:length line) (:length line))
                 (when (zero? (ref line i))
                   (return i))))

  (defn line-indent-depth (self pos-y)
        (def line (:get-line self pos-y))
        (when-not line (return 0))
        (dotimes (i (:length line) (:length line))
                 (when (or (zero? (ref line i))
                           (> (ref line i) #x20))
                   (return i))))

  (defn beginning-of-line (self)
        (set! self.pos-x 0))

  (defn start-of-line (self)
        (def depth (:line-indent-depth self self.pos-y))
        (if (> self.pos-x depth)
            (set! self.pos-x depth)
            (:beginning-of-line self)))

  (defn end-of-line (self)
        (set! self.pos-x (:line-length self self.pos-y)))

  (defn beginning-of-buffer (self)
        (set! self.pos-y 0)
        (set! self.pos-x 0))

  (defn end-of-buffer (self)
        (set! self.pos-y (- (:length self.lines) 1))
        (:end-of-line self))

  (defn backward-char (self)
        (def pos-x self.pos-x)
        (when (< pos-x 1)
          (def pos-y self.pos-y)
          (when (< pos-y 1)
            (return))
          (set! self.pos-y (dec pos-y))
          (set! self.pos-x (:line-length self (dec pos-y)))
          (return))
        (set! self.pos-x (dec pos-x)))

  (defn previous-line (self)
        (def pos-x self.pos-x)
        (def pos-y self.pos-y)
        (when (< pos-y 1)
          (return))
        (set! self.pos-y (dec pos-y))
        (set! self.pos-x (min pos-x (:line-length self (dec pos-y)))))

  (defn next-line (self)
        (def pos-x self.pos-x)
        (def pos-y self.pos-y)
        (def lines self.lines)
        (def ll (- (:length lines) 1))
        (when (>= pos-y ll)
          (return))
        (set! self.pos-y (inc pos-y))
        (set! self.pos-x (min pos-x (:line-length self (inc pos-y)))))

  (defn forward-char (self)
        (def pos-x self.pos-x)
        (def pos-y self.pos-y)
        (def ll (:line-length self pos-y))
        (when (>= pos-x ll)
          (when (>= (inc pos-y) (:length self.lines))
            (return))
          (set! self.pos-x 0)
          (set! self.pos-y (inc pos-y))
          (return))
        (set! self.pos-x (inc pos-x)))

  (defn delete-forward-char (self)
        (when (:delete-region self) (return))
        (def line (:get-line self self.pos-y))
        (when-not line (return))
        (def pos-x self.pos-x)
        (def bl (- (:length line) 2))
        (def ll (:line-length self self.pos-y))
        (when (< bl 0)
          (return))
        (when (>= pos-x ll)
          (when (>= self.pos-y (- (:length self.lines) 1))
            (return))
          (set! self.pos-x 0)
          (set! self.pos-y (inc self.pos-y))
          (def clipboard (:kill-line self))
          (:remove-line self)
          (set! self.pos-y (- self.pos-y 1))
          (set! self.pos-x pos-x)
          (:insert-text self clipboard)
          (set! self.pos-x pos-x)
          (return))
        (while (<= pos-x bl)
          (set! line pos-x (ref line (inc pos-x)))
          (inc! pos-x))
        (set! line (- (:length line) 1) 0))

  (defn remove-line (self y)
        (when (:delete-region self) (return))
        (set! y (or y self.pos-y))
        (def lines self.lines)
        (def ll (- (:length lines) 1))
        (def pos-y self.pos-y)
        (when (zero? pos-y) (return))
        (while (< pos-y ll)
          (set! lines pos-y (ref lines (inc pos-y)))
          (inc! pos-y))
        (:length! lines (max 0 ll)))

  (defn backward-delete-line (self)
        (def clipboard (:kill-line self))
        (:remove-line self)
        (set! self.pos-y (- self.pos-y 1))
        (set! self.pos-x (:line-length self self.pos-y))
        (def pos-x self.pos-x)
        (:insert-text self clipboard)
        (set! self.pos-x pos-x))

  (defn backward-delete-char (self)
        (when (:delete-region self) (return))
        (def line (:get-line self self.pos-y))
        (when-not line (return))
        (def pos-x self.pos-x)
        (when (< pos-x 1)
          (return (:backward-delete-line self)))
        (def bl (- (:length line) 1))
        (while (<= pos-x bl)
          (set! line (- pos-x 1) (ref line pos-x))
          (inc! pos-x))
        (set! line bl 0)
        (set! self.pos-x (- self.pos-x 1)))

  (defn keyboard-quit (self)
        (set! self.mark #nil))

  (defn use-region? (self)
        (pair? self.mark))

  (defn region-start-y (self)
        (min self.pos-y
             (cdr self.mark)))

  (defn region-end-y (self)
        (max self.pos-y
             (cdr self.mark)))

  (defn region-start-x (self)
        (if (= self.pos-y (cdr self.mark))
            (min self.pos-x
                 (car self.mark))
            (if (< self.pos-y (cdr self.mark))
                self.pos-x
                (car self.mark))))

  (defn region-end-x (self)
        (if (= self.pos-y (cdr self.mark))
            (max self.pos-x
                 (car self.mark))
            (if (< self.pos-y (cdr self.mark))
                (car self.mark)
                self.pos-x)))

  (defn set-mark-command (self)
        (set! self.mark (cons self.pos-x self.pos-y)))

  (defn mark-whole-buffer (self)
        (:end-of-buffer self)
        (:set-mark-command self)
        (:beginning-of-buffer self))

  (defn delete-region (self)
        (when (nil? self.mark)
          (return #f))
        (def rs-y (:region-start-y self))
        (def re-y (:region-end-y self))
        (def rs-x (:region-start-x self))
        (def re-x (:region-end-x self))
        (set! self.mark #nil)
        (def times (if (= rs-y re-y)
                       (- re-x rs-x)
                       (+ re-x (- (inc (:line-length self rs-y)) rs-x))))
        (def line-y (inc rs-y))
        (while (< line-y re-y)
          (set! self.pos-y (inc rs-y))
          (:remove-line self)
          (inc! line-y))
        (set! self.pos-x rs-x)
        (set! self.pos-y rs-y)
        (dotimes (i times)
                 (:delete-forward-char self))
        #t)

  (defn get-region (self)
        (when (nil? self.mark)
          (return ""))
        (def rs-y (:region-start-y self))
        (def re-y (:region-end-y self))
        (def rs-x (:region-start-x self))
        (def re-x (:region-end-x self))

        (def buf #nil)
        (def lines self.lines)
        (def line-y rs-y)
        (while (<= line-y re-y)
          (def mark-start 0)
          (def mark-end 0)
          (set! mark-end (:line-length self line-y))
          (when (= line-y rs-y)
            (set! mark-start rs-x))
          (when (= line-y re-y)
            (set! mark-end re-x))
          (set! buf (cons (buffer->string (ref lines line-y) mark-end mark-start) buf))
          (inc! line-y))
        (join (nreverse buf) "\n"))

  (defn insert-char (self c)
        (:delete-region self)
        (when (zero? c) (return))
        (when (= c #\LineFeed)
          (return (:insert-newline self)))
        (def line (:get-line self self.pos-y))
        (when-not line (return))
        (def pos-x self.pos-x)
        (def i (- (:length line) 1))
        (when-not (zero? (ref line i))
                  (:length! line (+ (:length line) 16))
                  (set! i (- (:length line) 1)))
        (while (> i pos-x)
          (set! line i (ref line (dec i)))
          (dec! i))
        (set! line pos-x c)
        (set! self.pos-x (inc pos-x)))

  (defn insert-text (self text)
        (dotimes (i (:length text))
                 (:insert-char self (ref text i))))

  (defn kill-line (self)
        (set! self.mark #nil)
        (def lines self.lines)
        (def pos-x self.pos-x)
        (def cur-line (ref lines self.pos-y))
        (def ll (:line-length self self.pos-y))
        (def ret (buffer->string (:cut cur-line pos-x ll)))
        (while (< pos-x ll)
          (set! cur-line pos-x 0)
          (inc! pos-x))
        (return ret))

  (defn insert-newline (self)
        (:delete-region self)
        (def lines self.lines)
        (:length! lines (inc (:length lines)))

        (def clipboard (:kill-line self))
        (set! self.pos-y (inc self.pos-y))
        (def ll self.pos-y)
        (def pos-y (- (:length lines) 1))
        (while (> pos-y ll)
          (set! lines pos-y (ref lines (- pos-y 1)))
          (set! pos-y (- pos-y 1)))
        (set! lines self.pos-y (buffer/allocate 16))
        (set! self.pos-x 0)
        (:insert-text self clipboard)
        (set! self.pos-x 0))

  (defn goto-line (self line)
        (set! self.pos-y (max 0 (min (- (:length self.lines) 1) line)))
        (set! self.pos-x (max 0 (min (- (:line-length self self.pos-y) 1) self.pos-x))))

  (defn scroll-up-command (self)
        (:goto-line self (+ self.pos-y self.scroll-interval)))

  (defn scroll-down-command (self)
        (:goto-line self (- self.pos-y self.scroll-interval)))

  (defn get-buf-name (self buf)
        (def filename self.filename)
        (def saved (if self.changed "*" ""))
        (fmt "{filename}{saved}")))