racketscript · leiDnedyA · Aug 16, 2023 · Aug 16, 2023
diff --git a/racketscript-extras/racketscript/htdp/peer-universe.rkt b/racketscript-extras/racketscript/htdp/peer-universe.rkt
diff --git a/racketscript-extras/racketscript/htdp/private/peer-universe/debug-tools.rkt b/racketscript-extras/racketscript/htdp/private/peer-universe/debug-tools.rkt
@@ -0,0 +1,20 @@
+#lang racketscript/base
+
+(require "encode-decode.rkt")
+
+(provide console-log-rkt-list
+         test-encoding)
+
+(define (console-log-rkt-list l)
+  (if (list? l) (#js*.console.log (foldl (lambda (curr res)
+                                    (#js.res.push curr)
+                                    res)
+                                  ($/array) l))
+                (#js*.console.log l)))
+
+(define (test-encoding val)
+  (define result (decode-data (encode-data val)))
+  (#js*.console.log val)
+  (#js*.console.log result)
+  (#js*.console.log (js-string (format "val == result? : ~a" (equal? val result))))
+  (void))
diff --git a/racketscript-extras/racketscript/htdp/private/peer-universe/encode-decode.rkt b/racketscript-extras/racketscript/htdp/private/peer-universe/encode-decode.rkt
@@ -0,0 +1,88 @@
+#lang racketscript/base
+
+(provide encode-data
+         decode-data)
+
+(require "util.rkt")
+
+(define DATA-TYPE-WARNING #js"racketscript/htdp/universe: Unsupported datatype being passed to/from server.")
+
+(define (encode-array arr)
+  (#js.arr.map (lambda (elem) (encode-data elem))))
+
+(define (decode-array arr)
+  (#js.arr.map (lambda (elem) (decode-data elem))))
+
+(define (encode-object obj)
+  (define keys (#js*.Object.keys obj))
+  (#js.keys.reduce (lambda (res key)
+                     ($/:= ($ res key) (encode-data ($ obj key)))
+                     res)
+                   ($/obj)))
+
+(define (decode-object obj)
+  (define keys (#js*.Object.keys obj))
+  (#js.keys.reduce (lambda (res key)
+                                 ($/:= ($ res key) (decode-data ($ obj key)))
+                                 res)
+                               ($/obj)))
+
+#|
+('test "some_string" #js"test" {test: "test"})
+
+
+"test"
+{
+  val: "test", type: "string"
+}
+
+'sym
+{
+  val: "sym", type: "symbol"
+}
+
+|#
+
+(define (encode-data data)
+  (cond [(list? data) (foldl (lambda (curr result)
+                               (#js.result.push (encode-data curr))
+                               result)
+                      ($/array)
+                      data)]
+        [(null? data)      ($/obj [type #js"null"])]
+        [(undefined? data) ($/obj [type #js"undefined"])]    
+        [(number? data)    ($/obj [type #js"number"]
+                                  [val data])]
+        [(string? data)    ($/obj [type #js"string"]
+                                  [val (js-string data)])]
+        [(symbol? data)    ($/obj [type #js"symbol"]
+                                  [val (js-string (symbol->string data))])]
+        [(boolean? data)   ($/obj [type #js"boolean"]
+                                  [val data])]
+        [(js-string? data) ($/obj [type #js"js-string"]
+                                  [val data])]
+        [(js-array? data)  ($/obj [type #js"js-array"]
+                                  [val (encode-array data)])]
+        [(js-object? data) ($/obj [type #js"js-object"]
+                                  [val (encode-object data)])]
+        [else              (begin 
+                             (#js*.console.warn ($/array DATA-TYPE-WARNING data))
+                             ($/obj [type #js"unknown"]
+                                  [val data]))]))
+
+(define (decode-data data)
+  (cond [(#js*.Array.isArray data) (#js.data.reduce (lambda (result curr)
+                                                      (append result (list (decode-data curr))))
+                                                    '())]
+        [($/binop == #js.data.type #js"null") $/null]
+        [($/binop == #js.data.type #js"undefined") $/undefined]
+        [($/binop == #js.data.type #js"number")    #js.data.val]
+        [($/binop == #js.data.type #js"string")    (js-string->string #js.data.val)]
+        [($/binop == #js.data.type #js"symbol")    (string->symbol (js-string->string #js.data.val))]
+        [($/binop == #js.data.type #js"boolean")   #js.data.val]
+        [($/binop == #js.data.type #js"js-string") #js.data.val]
+        [($/binop == #js.data.type #js"js-array")  (decode-array #js.data.val)]
+        [($/binop == #js.data.type #js"js-object") (decode-object #js.data.val)]
+        [($/binop == #js.data.type #js"unknown")   (begin
+                                                     (#js*.console.warn DATA-TYPE-WARNING)
+                                                     #js.data.val)]))
diff --git a/racketscript-extras/racketscript/htdp/private/peer-universe/jscommon.rkt b/racketscript-extras/racketscript/htdp/private/peer-universe/jscommon.rkt
@@ -0,0 +1,91 @@
+#lang racketscript/base
+
+(require (for-syntax racketscript/base
+                     syntax/parse))
+
+(provide :=
+         *this*
+         *null*
+         *undefined*
+         new
+         define-proto
+         set-object!
+         schedule-method
+         schedule-animation-frame
+         document
+         console
+         Math
+         Path2D
+         abs
+         sin
+         cos
+         floor
+         abs+ceil
+         max
+         min
+         twice
+         half
+         (rename-out [field-λ λ]))
+
+;;-----------------------------------------------------------------------------
+;; Interop helpers
+
+(define-syntax  :=        (make-rename-transformer #'$/:=))
+(define-syntax  new       (make-rename-transformer #'$/new))
+(define-syntax *this*     (make-rename-transformer #'$/this))
+(define-syntax *null*       (make-rename-transformer #'$/null))
+(define-syntax *undefined*  (make-rename-transformer #'$/undefined))
+
+(begin-for-syntax
+  (define-syntax-class field
+    #:description "a key-value pair for object"
+    (pattern [name:id val:expr])))
+
+(define-syntax (field-λ stx)
+  (syntax-parse stx
+    [(_ formals (~datum #:with-this) self:id body ...)
+     #'(λ formals
+         (define self *this*)
+         body ...)]
+    [(_ formals body ...) #'(λ formals body ...)]))
+
+(define-syntax (define-proto stx)
+  (syntax-parse stx
+    [(define-proto name:id init:expr field:field ...)
+     #`(begin
+         (define name init)
+         #,(when (attribute field)
+             #`(begin
+                 (:= ($ name 'prototype 'field.name) field.val) ...)))]))
+
+(define-syntax (set-object! stx)
+  (syntax-parse stx
+    [(set-object! obj:expr f:field ...)
+     #`(begin (:= ($ obj 'f.name) f.val) ...)]))
+
+
+(define-syntax-rule (schedule-method this method interval)
+  (let ([self this])
+    (#js*.window.setTimeout (λ ()
+                             (($ self method)))
+                            interval)))
+
+(define-syntax-rule (schedule-animation-frame this step)
+  (let ([self this])
+    (#js*.window.requestAnimationFrame (λ ()
+                                         (($ self step))))))
+
+;;-----------------------------------------------------------------------------
+;; Helper functions
+
+(define document  #js*.window.document)
+(define console   #js*.window.console)
+(define Math      #js*.window.Math)
+(define Path2D    #js*.window.Path2D)
+(define abs+ceil  (λ (n) (abs (ceiling n))))
+
+(define-syntax-rule (twice e)
+  (* e 2))
+
+(define-syntax-rule (half e)
+  (/ e 2))
diff --git a/racketscript-extras/racketscript/htdp/private/peer-universe/server-gui.rkt b/racketscript-extras/racketscript/htdp/private/peer-universe/server-gui.rkt
@@ -0,0 +1,115 @@
+#lang racketscript/base
+
+(require (for-syntax racketscript/base
+                     syntax/parse)
+         "encode-decode.rkt"
+         "debug-tools.rkt"
+         "universe-primitives.rkt"
+         "jscommon.rkt")
+
+(provide server-gui)
+
+(define DEFAULT-DISPLAY-MODE #js"block")
+(define WIDTH 500)
+(define HEIGHT 300)
+
+(define-proto ServerLogger
+  (λ (root stop-callback restart-callback)
+    #:with-this this
+
+    ; <div id="server-logger-container">
+    ;     <checkbox>Auto-scroll</checkbox>
+    ;     <textbox>logged text</textbox>
+    ;     <div class="button-container">
+    ;          <button>stop</button>
+    ;         <button>stop and restart</button>
+    ;     </div>
+    ; </div>
+    (:= #js.this.logs  ($/array))
+    (:= #js.this.autoscroll? #true)
+
+    ;; Create elements
+    (:= #js.this.container      (#js*.document.createElement #js"div"))
+    (:= #js.this.textbox        (#js*.document.createElement #js"textarea"))
+    (:= #js.this.checkbox-div   (#js*.document.createElement #js"div"))
+    (:= #js.this.checkbox-label (#js*.document.createElement #js"label"))
+    (:= #js.this.checkbox       (#js*.document.createElement #js"input"))
+    (:= #js.this.button-div     (#js*.document.createElement #js"div"))
+    (:= #js.this.stop-button    (#js*.document.createElement #js"button"))
+    (:= #js.this.restart-button (#js*.document.createElement #js"button"))
+
+    ;; Configure elements
+    (:= #js.this.container.style.display #js"none")
+    (:= #js.this.container.style.width  (js-string (format "~apx" WIDTH)))
+    (:= #js.this.container.style.height (js-string (format "~apx" HEIGHT)))
+
+    (:= #js.this.textbox.style.width #js"inherit")
+    (:= #js.this.textbox.style.height #js"inherit")
+
+    (:= #js.this.checkbox-label.for #js"autoscroll")
+    (:= #js.this.checkbox-label.innerHTML #js"autoscroll with new input")
+    (:= #js.this.checkbox.type #js"checkbox")
+    (:= #js.this.checkbox.onclick (lambda () (:= #js.this.autoscroll? #js.this.checkbox.checked)))
+    (:= #js.this.checkbox.checked #true)
+
+    (:= #js.this.stop-button.innerHTML          #js"stop")
+    (:= #js.this.stop-button.style.grid-area    #js"stop")
+    (:= #js.this.stop-button.onclick            stop-callback)
+    (:= #js.this.restart-button.innerHTML       #js"restart")
+    (:= #js.this.restart-button.style.grid-area #js"restart")
+    (:= #js.this.restart-button.onclick         restart-callback)
+    (:= #js.this.button-div.style.width         #js"100%")
+    (:= #js.this.button-div.style.display       #js"grid")
+    (:= #js.this.button-div.style.gridTemplateAreas
+        #js"'stop restart'")
+
+    ;; Add elements to document
+    (#js.this.checkbox-div.appendChild #js.this.checkbox-label)
+    (#js.this.checkbox-div.appendChild #js.this.checkbox)
+
+    (#js.this.button-div.appendChild #js.this.stop-button)
+    (#js.this.button-div.appendChild #js.this.restart-button)
+
+    (#js.this.container.appendChild #js.this.textbox)
+    (#js.this.container.appendChild #js.this.checkbox-div)
+    (if (and restart-callback stop-callback)
+        (#js.this.container.appendChild #js.this.button-div)
+        (void))
+    (#js.root.appendChild #js.this.container)
+    this)
+    [log
+     (λ (text) 
+       #:with-this this
+       (#js.this.logs.push (js-string text))
+       (#js.this.render)
+       (#js*.console.log (js-string text))
+       (void))]
+    [show
+     (λ ()
+       #:with-this this
+       (:= #js.this.container.style.display DEFAULT-DISPLAY-MODE)
+       (void))]
+    [hide
+     (λ ()
+       #:with-this this
+       (:= #js.this.container.style.display #js"none")
+       (void))]
+    [render
+     (λ ()
+       #:with-this this
+       (define log-string (#js.this.logs.reduce (λ (res curr)
+                                                  (if ($/binop === res #js"")
+                                                      (js-string curr)
+                                                      ($/+ res #js"\n\n" (js-string curr))))
+                                                #js""))
+       (:= #js.this.textbox.innerHTML log-string)
+       (cond [(equal? #js.this.autoscroll? #true)
+              (:= #js.this.textbox.scrollTop #js.this.textbox.scrollHeight)]
+             [else (void)])
+       (void))])
+
+(define (make-gui root stop-callback restart-callback)
+  (new (ServerLogger root stop-callback restart-callback)))
+
+(define (server-gui [root-element #js*.document.body] [stop-callback #false] [restart-callback #false])
+  (make-gui root-element stop-callback restart-callback))