From 4f84e14e3b1cd73226c29abe2f04afc72f41746d Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Sat, 20 Dec 2014 18:09:40 -0500
Subject: [PATCH] More work on rmacs

---
 rmacs/display.rkt | 152 ++++++++++++++++++++++++++++++++++++----------
 rmacs/main.rkt    |  20 ++++++
 rmacs/window.rkt  |  34 +++++++++++
 3 files changed, 175 insertions(+), 31 deletions(-)
 create mode 100644 rmacs/main.rkt
 create mode 100644 rmacs/window.rkt

diff --git a/rmacs/display.rkt b/rmacs/display.rkt
index 7c15404..a88521f 100644
--- a/rmacs/display.rkt
+++ b/rmacs/display.rkt
@@ -1,34 +1,124 @@
 #lang racket/base
 
-(require "buffer.rkt")
+(provide (struct-out tty)
+         stdin-tty
+         tty-display
+         tty-clear
+         tty-reset
+         tty-goto
+         tty-style
+         tty-style-reset
 
-;; Finseth's book defines a C routine, Framer(), which is intended to
-;; ensure that the `top_of_window` mark, denoting the position where
-;; display should begin for the current window, is in a sane position.
-;; The mark is left alone unless the cursor is outside the currently
-;; displayed window, either above or below. If the mark needs to be
-;; moved, it is moved to a line such that the cursor, after redisplay,
-;; will end up at a configurable percentage of the way down the
-;; window.
-;;
-;; MarkType Location Buffer -> Buffer
-;; Ensures the given mark is sanely positioned as a top-of-window mark
-;; with respect to the given cursor position.
-(define (frame-buffer! top-of-window-mtype cursor-position window-height buf
-                       #:preferred-position-fraction [preferred-position-fraction 1/2])
-  (define old-top-of-window-pos (buffer-mark-pos buf top-of-window-mtype))
-  (define preferred-distance-from-bottom (ceiling (* window-height (- 1 preferred-position-fraction))))
-  (let loop ((pos (buffer-find buf "\n" #:forward? #f #:move? #f))
-             (line-count 0)
-             (top-of-window-pos old-top-of-window-pos))
-    (define new-top-of-window-pos
-      (if (= line-count preferred-distance-from-bottom) pos top-of-window-pos))
-    (cond
-     [(<= pos old-top-of-window-pos)
-      buf]
-     [(= line-count window-height)
-      (buffer-mark! buf top-of-window-mtype #:position new-top-of-window-pos)]
-     [else
-      (loop (buffer-find buf "\n" #:forward? #f #:move? #f #:position (- pos 1))
-            (+ line-count 1)
-            new-top-of-window-pos)])))
+         ;; From ansi
+         color-black
+         color-red
+         color-green
+         color-yellow
+         color-blue
+         color-magenta
+         color-cyan
+         color-white)
+
+(require racket/match)
+(require ansi)
+
+(struct tty (input ;; InputPort
+             output ;; OutputPort
+             key-reader ;; InputPort -> Key
+             [rows #:mutable] ;; Nat
+             [columns #:mutable] ;; Nat
+             [cursor-row #:mutable] ;; Nat
+             [cursor-column #:mutable] ;; Nat
+             [foreground-color #:mutable] ;; Nat
+             [background-color #:mutable] ;; Nat
+             [bold? #:mutable] ;; Boolean
+             [italic? #:mutable] ;; Boolean
+             ) #:transparent)
+
+(define *stdin-tty* #f)
+(define (stdin-tty)
+  (when (not *stdin-tty*)
+    (tty-raw!)
+    (set! *stdin-tty*
+          (tty (current-input-port)
+               (current-output-port)
+               lex-lcd-input
+               24
+               80
+               1
+               1
+               color-white
+               color-black
+               #f
+               #f))
+    (tty-reset *stdin-tty*)
+    (plumber-add-flush! (current-plumber)
+                        (lambda (h)
+                          (tty-style-reset *stdin-tty*)
+                          (tty-goto *stdin-tty* (tty-rows *stdin-tty*) 1))))
+  *stdin-tty*)
+
+(define (tty-display tty . items)
+  (for ((i items)) (display i (tty-output tty)))
+  (flush-output (tty-output tty)))
+
+(define (tty-goto tty row0 column0)
+  (define row (max 1 (min (tty-rows tty) row0)))
+  (define column (max 1 (min (tty-columns tty) column0)))
+  (tty-display tty (goto row column))
+  (set-tty-cursor-row! tty row)
+  (set-tty-cursor-column! tty column)
+  tty)
+
+(define (tty-clear tty)
+  (tty-style tty) ;; applies style from tty
+  (tty-display tty (clear-screen/home))
+  (set-tty-cursor-row! tty 1)
+  (set-tty-cursor-column! tty 1)
+  tty)
+
+(define (tty-style tty
+                   #:foreground-color [fgcolor (tty-foreground-color tty)]
+                   #:background-color [bgcolor (tty-background-color tty)]
+                   #:bold? [bold? (tty-bold? tty)]
+                   #:italic? [italic? (tty-italic? tty)])
+  (tty-display tty
+               (select-graphic-rendition)
+               (apply select-graphic-rendition
+                      `(,@(if bold? (list style-bold) (list))
+                        ,@(if italic? (list style-italic/inverse) (list))
+                        ,(style-text-color fgcolor)
+                        ,(style-background-color bgcolor))))
+  (set-tty-foreground-color! tty fgcolor)
+  (set-tty-background-color! tty bgcolor)
+  (set-tty-bold?! tty bold?)
+  (set-tty-italic?! tty italic?)
+  tty)
+
+(define (tty-style-reset tty)
+  (tty-style tty
+             #:foreground-color color-white
+             #:background-color color-black
+             #:bold? #f
+             #:italic? #f))
+
+(define (collect-position-report tty)
+  (let loop ()
+    (sync/timeout 0.5
+                  (handle-evt (tty-input tty)
+                              (lambda (p)
+                                (match ((tty-key-reader tty) p)
+                                  [(? position-report? r) r]
+                                  [_ (loop)]))))))
+
+(define (tty-reset tty)
+  (tty-display tty
+               (clear-screen)
+               (goto 999 999)
+               (position-report-request))
+  (define report (or (collect-position-report tty)
+                     (position-report 24 80))) ;; TODO: have a more flexible fallback
+  (tty-clear tty)
+  (set-tty-rows! tty (position-report-row report))
+  (set-tty-columns! tty (position-report-column report))
+  tty)
diff --git a/rmacs/main.rkt b/rmacs/main.rkt
new file mode 100644
index 0000000..6008b65
--- /dev/null
+++ b/rmacs/main.rkt
@@ -0,0 +1,20 @@
+#lang racket/base
+
+(require "display.rkt")
+(require racket/match)
+
+(define (main)
+  (define t (stdin-tty))
+  (tty-style t #:bold? #t #:background-color color-blue)
+  (tty-display t (format "Your screen is ~a rows and ~a columns.\r\n"
+                         (tty-rows t)
+                         (tty-columns t)))
+  (tty-style t #:bold? #f #:italic? #t)
+  (tty-display t "Italic.\r\n")
+  (tty-style t #:bold? #t)
+  (tty-display t "Bold and italic.\r\n")
+  (tty-style t #:bold? #f #:italic? #f)
+  (tty-display t "Neither.\r\n"))
+
+(module+ main
+  (void (main)))
diff --git a/rmacs/window.rkt b/rmacs/window.rkt
new file mode 100644
index 0000000..7c15404
--- /dev/null
+++ b/rmacs/window.rkt
@@ -0,0 +1,34 @@
+#lang racket/base
+
+(require "buffer.rkt")
+
+;; Finseth's book defines a C routine, Framer(), which is intended to
+;; ensure that the `top_of_window` mark, denoting the position where
+;; display should begin for the current window, is in a sane position.
+;; The mark is left alone unless the cursor is outside the currently
+;; displayed window, either above or below. If the mark needs to be
+;; moved, it is moved to a line such that the cursor, after redisplay,
+;; will end up at a configurable percentage of the way down the
+;; window.
+;;
+;; MarkType Location Buffer -> Buffer
+;; Ensures the given mark is sanely positioned as a top-of-window mark
+;; with respect to the given cursor position.
+(define (frame-buffer! top-of-window-mtype cursor-position window-height buf
+                       #:preferred-position-fraction [preferred-position-fraction 1/2])
+  (define old-top-of-window-pos (buffer-mark-pos buf top-of-window-mtype))
+  (define preferred-distance-from-bottom (ceiling (* window-height (- 1 preferred-position-fraction))))
+  (let loop ((pos (buffer-find buf "\n" #:forward? #f #:move? #f))
+             (line-count 0)
+             (top-of-window-pos old-top-of-window-pos))
+    (define new-top-of-window-pos
+      (if (= line-count preferred-distance-from-bottom) pos top-of-window-pos))
+    (cond
+     [(<= pos old-top-of-window-pos)
+      buf]
+     [(= line-count window-height)
+      (buffer-mark! buf top-of-window-mtype #:position new-top-of-window-pos)]
+     [else
+      (loop (buffer-find buf "\n" #:forward? #f #:move? #f #:position (- pos 1))
+            (+ line-count 1)
+            new-top-of-window-pos)])))