diff --git a/draw.rkt b/draw.rkt index fe29916..3327a1d 100644 --- a/draw.rkt +++ b/draw.rkt @@ -16,7 +16,8 @@ [underline . ,A:style-underline])) (define current-fg (make-parameter 'default)) (define current-bg (make-parameter 'default)) -(define current-display-drawing-parameters? (make-parameter #t)) +(define current-display-drawing-parameters? + (make-parameter (current-output-port))) (define symbol->color `#hasheq( [black . 0] [red . 1] [green . 2] [yellow . 3] @@ -32,8 +33,9 @@ (A:select-graphic-rendition A:style-default-background-color) (A:select-xterm-256-background-color (hash-ref symbol->color c)))) (define (set-drawing-parameters!) - (when (current-display-drawing-parameters?) - (display (get-drawing-parameters)))) + (cond + [(current-display-drawing-parameters?) + => (λ (op) (display (get-drawing-parameters) op))])) (define (get-drawing-parameters) (string-append (A:select-graphic-rendition (hash-ref symbol->style (current-style))) @@ -45,39 +47,43 @@ ;; ! : (row col char -> void) row col -> bool (struct raart (w h !)) -(define (draw x [row 1] [col 1] +(define (draw x + #:output [op (current-output-port)] #:clear? [clear? #t]) (match-define (raart w h !) x) - (display (A:dec-soft-terminal-reset)) + (display (A:dec-soft-terminal-reset) op) (when clear? - (display (A:clear-screen/home))) - (set-drawing-parameters!) - (! (λ (r c ch) - (display (A:goto r c)) - (display ch) - #t) - row col) - (display (A:goto (+ row h) (+ col w)))) + (display (A:clear-screen/home) op)) + (parameterize ([current-display-drawing-parameters? op]) + (set-drawing-parameters!) + (! (λ (r c ch) + (display (A:goto r c) op) + (when ch (display ch op)) + #t) + 1 1)) + (flush-output op)) -(define (draw-here x) +(define (draw-here x #:output [op (current-output-port)]) (match-define (raart w h !) x) (define init-dp (get-drawing-parameters)) (define def (cons init-dp #\space)) (define rows (build-vector h (λ (i) (make-vector w def)))) - (! (λ (r c ch) - (vector-set! (vector-ref rows r) c - (cons (get-drawing-parameters) ch)) - #t) - 0 0) + (parameterize ([current-display-drawing-parameters? #f]) + (! (λ (r c ch) + (vector-set! (vector-ref rows r) c + (cons (get-drawing-parameters) ch)) + #t) + 0 0)) (for/fold ([last-dp init-dp]) ([r (in-vector rows)]) (begin0 (for/fold ([last-dp last-dp]) ([dp*ch (in-vector r)]) (match-define (cons this-dp ch) dp*ch) (unless (string=? this-dp last-dp) - (display this-dp)) - (display ch) + (display this-dp op)) + (display ch op) this-dp) - (newline))) + (newline op))) + (flush-output op) (void)) (define-syntax (with-maybe-parameterize stx) @@ -334,6 +340,12 @@ (when ? (f)) ?))) +(define (place-cursor-after x cr cc) + (match-define (raart w h !) x) + (raart w h (λ (d r c) + (strict-or (! d r c) + (d cr cc #f))))) + (define style/c (apply or/c (hash-keys symbol->style))) (define color/c (apply or/c (hash-keys symbol->color))) (define valign/c (or/c 'top 'center 'bottom)) @@ -341,13 +353,14 @@ (provide (contract-out [raart? (-> any/c boolean?)] - [draw-here (-> raart? void?)] [draw (->* (raart?) - (exact-positive-integer? - exact-positive-integer? + (#:output output-port? #:clear? boolean?) void?)] + [draw-here + (->* (raart?) (#:output output-port?) + void?)] [style/c contract?] [style (-> style/c raart? raart?)] [color/c contract?] @@ -404,5 +417,8 @@ raart?)] [text-rows (-> (listof (listof any/c)) (listof (listof raart?)))] - [if-drawn (-> (-> any) raart? raart?)]) + [if-drawn (-> (-> any) raart? raart?)] + [place-cursor-after + (-> raart? exact-positive-integer? exact-positive-integer? + raart?)]) place-at*) diff --git a/lux-chaos.rkt b/lux-chaos.rkt new file mode 100644 index 0000000..69ea576 --- /dev/null +++ b/lux-chaos.rkt @@ -0,0 +1,143 @@ +#lang racket/base +(require racket/match + racket/contract/base + racket/list + racket/async-channel + racket/system + ansi + (submod ansi/lcd-terminal event-structs) + ansi/private/tty-raw-extension + unix-signals + lux/chaos + raart/draw) +(provide (all-from-out (submod ansi/lcd-terminal event-structs))) + +(struct term (f in out)) + +(define default-tty "/dev/tty") + +#; +(define stty-minus-f-arg-string + (case (system-type 'os) + ((macosx) "-f") + (else "-F"))) +#; +(define (open-term #:tty [tty default-tty]) + (system* "/bin/stty" + stty-minus-f-arg-string + tty + "raw" + "-echo") + (define-values (in out) + (open-input-output-file tty #:exists 'update)) + (term tty in out)) +#; +(define (close-term t) + (match-define (term f in out) t) + (close-input-port in) + (close-output-port out) + (system* "/bin/stty" + stty-minus-f-arg-string + f + "cooked" + "echo")) + +(define (open-term) + (tty-raw!) + (term #f (current-input-port) (current-output-port))) +(define (close-term t) + (tty-restore!)) + +(define (with-term f #:tty [tty default-tty]) + (define t (open-term #:tty tty)) + (define (close!) (close-term t)) + (with-handlers ([exn:fail? (λ (x) (close!) (raise x))]) + (begin0 (f t) (close!)))) + +(define (display/flush v op) + (display v op) + (flush-output op)) + +(define (display/term t v) + (define op (term-out t)) + (unless (port-closed? op) + (display/flush v op))) + +;; Lux +(define x11-mouse-on + (string-append (set-mode x11-focus-event-mode) + (set-mode x11-any-event-mouse-tracking-mode) + (set-mode x11-extended-mouse-tracking-mode))) +(define x11-mouse-off + (string-append (reset-mode x11-extended-mouse-tracking-mode) + (reset-mode x11-any-event-mouse-tracking-mode) + (reset-mode x11-focus-event-mode))) +(define (make-raart #:alternate? [alternate? #f] + #:mouse? [mouse? #f]) + (define t (open-term)) + (define ch (make-async-channel)) + ;; Initialize term + (when alternate? + (display/term t (set-mode alternate-screen-mode))) + (when mouse? + (display/term t x11-mouse-on) + (plumber-add-flush! (current-plumber) + (lambda (handle) + (display/term t x11-mouse-off)))) + ;; Register for window change events + (display/term t (device-request-screen-size)) + (capture-signal! 'SIGWINCH) + (define sig-th + (thread + (λ () + (let loop () + (define s (read-signal)) + (match (lookup-signal-name s) + ['SIGWINCH (display/term t (device-request-screen-size)) + (loop)]))))) + ;; Listen for input + (define input-th + (thread + (λ () + (let loop () + (define v (lex-lcd-input (term-in t) #:utf-8? #t)) + (unless (eof-object? v) + (async-channel-put ch v) + (loop)))))) + ;; Return + (*term alternate? mouse? t ch sig-th input-th 80 24)) + +(struct *term + (alternate? mouse? t ch sig-th input-th [rows #:mutable] [cols #:mutable]) + #:methods gen:chaos + [(define (chaos-event c) + (handle-evt (*term-ch c) + (match-lambda + [(and e (screen-size-report rows cols)) + (set-*term-rows! c rows) + (set-*term-cols! c cols) + e] + [e e]))) + (define (chaos-output! c o) + (when o + (draw (crop 0 (*term-cols c) + 0 (*term-rows c) + o) + #:output (term-out (*term-t c))))) + (define (chaos-label! c l) + (display/term (*term-t c) (xterm-set-window-title l))) + (define (chaos-stop! c) + (define t (*term-t c)) + (when (*term-mouse? c) + (display/term t x11-mouse-off)) + (when (*term-alternate? c) + (display/term t (reset-mode alternate-screen-mode))) + (kill-thread (*term-sig-th c)) + (kill-thread (*term-input-th c)) + (release-signal! 'SIGWINCH) + (close-term t))]) + +(provide + (contract-out + [make-raart + (->* () (#:alternate? boolean?) chaos?)])) diff --git a/main.rkt b/main.rkt index f469e96..9dc0df1 100644 --- a/main.rkt +++ b/main.rkt @@ -1,2 +1,3 @@ #lang reprovide "draw.rkt" +"lux-chaos.rkt" diff --git a/size.rkt b/size.rkt index c7d1afd..696ce6b 100644 --- a/size.rkt +++ b/size.rkt @@ -1,92 +1,9 @@ #lang racket/base -(require racket/match - racket/list - racket/system - ansi) -(define stty-minus-f-arg-string - (case (system-type 'os) - ((macosx) "-f") - (else "-F"))) +;; xxx Do the rune thing as well (and think about mouse events) -(define (read-until ip char) - (define byte (char->integer char)) - (apply bytes - (let loop () - (match (read-byte ip) - [(== byte) empty] - [next (cons next (loop))])))) - -(define (bytes->number bs) - (string->number (bytes->string/utf-8 bs))) - -(define default-tty "/dev/tty") -(struct term (f in out)) -(define (open-term #:tty [tty default-tty]) - (system* "/bin/stty" - stty-minus-f-arg-string - tty - "raw" - "-echo") - (define-values (in out) - (open-input-output-file tty #:exists 'update)) - (term tty in out)) - -(define (close-term t) - (match-define (term f in out) t) - (close-input-port in) - (close-output-port out) - (system* "/bin/stty" - stty-minus-f-arg-string - f - "cooked" - "echo")) - -(define (with-term f #:tty [tty default-tty]) - (define t (open-term #:tty tty)) - (define (close!) (close-term t)) - (with-handlers ([exn:fail? (λ (x) (close!) (raise x))]) - (begin0 (f t) (close!)))) - -(define (with-term* t f) - (if t (f t) (with-term f))) - -(define (screen-size [t #f]) - (with-term* t - (λ (t) - (match-define (term _ in out) t) - (write-bytes #"\e[18t" out) (flush-output out) - (match (read-until in #\;) - [#"\e[8" - (define row-s (read-until in #\;)) - (define col-s (read-until in #\t)) - (values (bytes->number row-s) - (bytes->number col-s))] - [x (error 'screen-size "Something weird happened, got ~e" x)])))) - -(define (cursor-position [t #f]) - (with-term* t - (λ (t) - (match-define (term _ in out) t) - (display (position-report-request) out) (flush-output out) - (match (read-bytes 2 in) - [#"\e[" - (define row-s (read-until in #\;)) - (define col-s (read-until in #\R)) - (values (bytes->number row-s) - (bytes->number col-s))] - [x (error 'cursor-position "Something weird happened, got ~e" x)])))) - -;; xxx xterm-set-window-title -#;(begin - (display (A:set-mode A:alternate-screen-mode)) - (display (A:reset-mode A:alternate-screen-mode))) - -;; xxx Do I make a 'lux chaos' for this? -;; -;; Or do I do the rune thing and make a separation between the -;; commands and the keys? Also, how should the mouse events fit -;; into that? +;; xxx cool to support images (iterm2, urxvt, kitty, etc, but seem to +;; all be broken in tmux) ;; xxx render xexpr-like thing ;; xxx text... (fit text inside a width) @@ -95,8 +12,5 @@ ;; xxx make a "Web" browser ;; xxx use if-drawn to figure out what links are on screen -(module+ main - (with-term - (λ (t) - (screen-size t) - (cursor-position t)))) +;; xxx interactable thing --- figure out pos&dimensions on screen for +;; supporting mouse