Welcome to the CHICKEN Scheme pasting service

#!/usr/bin/env chicken-scheme
;; -*- mode: scheme; -*-

(use tcp extras irregex
     (prefix sdl2 sdl2:))

(define width 640)
(define height 480)

(on-exit sdl2:quit!)

(sdl2:set-main-ready!)
(sdl2:init! '(everything))

(define-values (_window renderer)
  (sdl2:create-window-and-renderer! width height))

(define port 8080)
(define listener (tcp-listen port))

(tcp-accept-timeout 20)

(define px-re '(: "PX " (=> x (+ num))
                  " " (=> y (+ num))
                  (? " "
                     (? (=> a (= 2 xdigit)))
                     (=> r (= 2 xdigit))
                     (=> g (= 2 xdigit))
                     (=> b (= 2 xdigit)))))

(let loop ()
  (when (not (sdl2:quit-requested?))
    (receive
     (i o)
     (condition-case
      (tcp-accept listener)
      ((exn i/o net) (values #f #f)))
     (let loop ((lines 0))
       (when (and i o (not (eof-object? (condition-case
                                         (peek-char i)
                                         ((exn i/o net) #!eof)))))
         ;; TODO: check whether this needs condition-case
         (let ((line (read-line i)))
           (cond
            ((equal? line "SIZE")
             (printf "[SIZE] ~a ~a\n" width height)
             (write-line (format "SIZE ~a ~a" width height) o))
            ((irregex-match px-re line) =>
             (lambda (match)
               (let ((x (string->number (irregex-match-substring match 'x)))
                     (y (string->number (irregex-match-substring match 'y)))
                     (a (irregex-match-substring match 'a))
                     (r (irregex-match-substring match 'r))
                     (g (irregex-match-substring match 'g))
                     (b (irregex-match-substring match 'b)))
                 (if (and r g b)
                     (let ((a (string->number (or a "ff") 16))
                           (r (string->number r 16))
                           (g (string->number g 16))
                           (b (string->number b 16)))
                       (printf "[POKE] ~a ~a: ~a ~a ~a ~a\n" x y a r g b)
                       (sdl2:render-draw-color-set! renderer (sdl2:make-color r g b a))
                       (sdl2:render-draw-point! renderer x y))
                     (begin
                       (printf "[PEEK] ~a ~a\n" x y)
                       ;; FIXME
                       (write-line (format "PX ~a ~a ff00ff" x y) o))))))
            (else
             (printf "[???] ~a\n" line)))
           ;; TODO: this should round-robin between clients, *then*
           ;; proceed with the lines of the original connection
           (if (< lines 100)
               (loop (add1 lines))
               (begin
                 (sdl2:render-present! renderer)
                 (loop 0))))))
     (when (and i o)
       (close-input-port i)
       (close-output-port o)))
    (sdl2:render-present! renderer)
    (loop)))

#!/usr/bin/env chicken-scheme
;; -*- mode: scheme; -*-

(use tcp extras posix matchable sdl2)

(define width 1024)
(define height 768)

(on-exit quit!)

(set-main-ready!)
(init! '(video))

(define window (create-window! "FLUTER" 0 0 width height))
(define renderer (create-renderer! window -1 '(accelerated)))
(define canvas (window-surface window))

(define port (if (< (length (argv)) 2) 8080 (second (argv))))
(define listener (tcp-listen port))

(tcp-accept-timeout 20)

(set-signal-handler! signal/int (lambda (_) (exit 0)))

(fprintf (current-error-port) "[INFO] Listening on port ~a~%" port)
(fprintf (current-error-port) "[INFO] Renderer flags: ~a~%" (renderer-info-flags (get-renderer-info renderer)))
(define (pad n)
  (string-append (if (< n 16) "0" "") (sprintf "~x" n)))

(define-record-printer sdl2:color
  (lambda (c p)
    (fprintf p "~a~a~a~a"
             (pad (color-a c))
             (pad (color-r c))
             (pad (color-g c))
             (pad (color-b c)))))

(define (handle-client i o)
  (define $-> string->number)
  (let loop ()
    (if (and i o (not (eof-object? (condition-case
                                      (peek-char i)
                                      ((exn i/o net) #!eof)))))
          ;; TODO: check whether this needs condition-case
        (let ((line (string-split (read-line i))))
;            (fprintf (current-error-port) "[line]: ~a~%" line)
          (match
           line
           (("SIZE")
            (fprintf (current-error-port) "[SIZE] ~a ~a\n" width height)
            (fprintf o "SIZE ~a ~a~%~!" width height))
           ;; (("PX" (? $-> x) (? $-> y))
           ;;  (let* ((c (surface-ref canvas ($-> x) ($-> y))))
           ;;    (fprintf o "~a~%~!" c)))
           (("PX" (? $-> x) (? $-> y) col)
            (let* ((r (string-chop col 2))
                   (rgb (map (cut string->number <> 16) r))
                   (rgba (if (= (length rgb) 3)
                             (append rgb (list 255))
                             (append (cdr rgb) (car rgb)))))
              (when (and (<= 0 ($-> x) (sub1 width))
                         (<= 0 ($-> y) (sub1 height)))
                    (render-draw-color-set! renderer (apply make-color rgba))
                    (render-draw-point! renderer ($-> x) ($-> y))
;                    (surface-set! canvas ($-> x) ($-> y) (apply make-color rgba))
                    )))
           (else (fprintf (current-error-port) "[???] ~a~%" line)))
          (loop))
          (begin
            (fprintf (current-error-port) "Ports closing~%")
            (close-input-port i)
            (close-output-port o)))))

(let ((t (current-milliseconds)))
  (let loop ()
    (let ((n (current-milliseconds)))
       (when (> (- n t) 20)
;             (update-window-surface! window)
             (render-present! renderer)
             (set! t n)))
    (receive
     (i o)
     (condition-case
      (tcp-accept listener)
      ((exn i/o net) (loop)))
     (thread-start!
      (make-thread
       (lambda ()
         (handle-client i o)))))
    (loop)))