More work on rmacs
This commit is contained in:
Tony Garnock-Jones
parent
c4c846e50b
commit
4f84e14e3b
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -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)])))
|
||||
Loading…
Reference in New Issue