Small Snippets with Wisp

;; 20 MiB res memory
import : srfi srfi-9 ;; records
         only (srfi srfi-1) fold
;; 37 MiB res memory
define-record-type <roll-result>
  roll-result a b c d e f g h i j k l m n o p
  . roll-result?
  . (a ra) (b rb) (c rc) (d rd) (e re) (f rf) (g rg) (h rh)
  . (i ri) (j rj) (k rk) (l rl) (m rm) (n rn) (o ro) (p rp) 
;; 48 MiB res memory
define up-to-one-million : iota : expt 2 20
;; 55 MiB res memory

define results-record : map (λ (x) (apply roll-result (iota 16 x))) up-to-one-million
;; 311 MiB res memory, diff: 256 MiB

define results-cons : map (λ (x) (fold cons x (iota 15 (+ x 1)))) up-to-one-million
;; 440 MiB res memory, diff: 384 MiB

define results-list : map (λ (x) (apply list (iota 16 x))) up-to-one-million
;; 457 MiB res memory, diff: 402 MiB

define 16-million-zeros-vector : make-vector 16000000 0
;; 179 MiB res memory, diff 124 MiB

define 16-million-zeros-u32vector : make-u32vector 16000000 0
;; 118 MiB res memory, diff 63 MiB

import : srfi srfi-1
define : roll-dice . dice
  . "Roll arbitrary DICE.

Each die is a list of its faces. Example: roll-dice '(1 2 3 4) '(1 2 3 4)"
  define : roll mod . dice
    . "Roll DICE with modifier MOD. Example: 1d6+2 is roll 2 '(1 2 3 4 5 6)"
    cond
       : null? dice
         . '()
       : null? : cdr dice
         map : λ (pip) : + pip mod
               car dice
       else
         apply append 
             map : λ (pip) : apply roll : cons (+ pip mod) : cdr dice
               car dice
  apply roll : cons 0 dice


define : frequency results
    . "Count the frequency of numbers in the results"
    define counter : make-hash-table
    define : count value
        hash-set! counter value
             + 1 : if (hash-ref counter value) (hash-ref counter value) 0
    map count results
    sort : hash-map->list cons counter
           λ (x y) : < (car x) (car y)

define d6 '(1 2 3 4 5 6)
define d10 '(0 1 2 3 4 5 6 7 8 9)
frequency : roll-dice d6 d6 d10

import (fibers) (fibers channels)

define c : make-channel

define : speaker
  define : put-and-yield msg
    ;; blocks until the message is received
    put-message c msg
    ;; allows other fibers to run, this is from (ice-9 threads)
    yield
  map put-and-yield
    iota 1000
  . #f ;; no result

define : writer1
  while #t
    ;; use only one display call to avoid re-ordering
    display : cons 'one (get-message c)
    ;; the newline could get re-ordered
    newline

define : writer2
  while #t 
    display : cons 'two (get-message c)
    newline

run-fibers
  λ :
    spawn-fiber writer1
    spawn-fiber writer2
    speaker ;; blocks until the last message has been taken
            ;; then the program ends

set! *random-state*  : random-state-from-platform
import : only (srfi :1) take

define : d10
  1+ (random 10)

define : roll1d10-exploding
  let loop : : res (d10)
     if : zero? (modulo res 10) ;; explode
          loop : + res (d10)
          . res

define : rollxd10 count keep
   let loop : (results '()) (count count)
     if : zero? count
       ;; sum biggest KEEP results
       apply + : take (sort results >) keep
       loop (cons (roll1d10-exploding) results) {count - 1}

import random

def rollxd10(count, keep):
    results = []
    for i in range(count):
        res = random.randint(1, 10)
        while (res % 10) == 0:
            res += random.randint(1, 10)
        results.append(res)
    results.sort()
    return sum(results[-keep:]) # last y results

define-handler 'GET "/hello" : hello-world-handler request body
  ;; definition here
  ;; result:
  values
    build-response
      . #:headers `((content-type . (text/plain)))
    . "Hello World" ;; body

;; an alist of handlers: path-prefix . procedure
define put-handlers '()
define get-handlers '()
;; adding a handler
define : register-handler method path-prefix proc
    define : add-handler handlers
       cons (cons path-prefix proc) handlers
    cond
        : equal? method 'GET
          set! get-handlers : add-handler get-handlers
        : equal? method 'PUT
          set! put-handlers : add-handler put-handlers
        else #f
;; finding a matching handler
define : find-handler method path
    define handlers
      ` : GET . ,get-handlers
          PUT . ,put-handlers
    define : matching? handler-entry
      string-prefix? (car handler-entry) path
    define : find-proc handlers
      and=> (find matching? handlers) cdr
    and=> (assoc-ref handlers method) find-proc

;; define-handler provides syntactic sugar for the handler definition
define-syntax-rule : define-handler method path-prefix (name request body) rest ...
  begin
      define (name request body) rest ...
      register-handler method path-prefix name
      . name

import : only (srfi srfi-11) let-values
         only (srfi srfi-1) find
         prefix (fibers web server) fibers: ;; using https://github.com/wingo/fibers
         prefix (fibers channels) fibers:
         prefix (fibers) fibers:
         web client
         web request
         web response
         web uri

define : run-ipv4-fibers-server handler-with-path ip port
    fibers:run-server handler-with-path #:family AF_INET
      . #:port port #:addr INADDR_ANY

define : run-ipv6-fibers-server handler-with-path ip port
    define s
        let : : s : socket AF_INET6 SOCK_STREAM 0
            setsockopt s SOL_SOCKET SO_REUSEADDR 1
            bind s AF_INET6 (inet-pton AF_INET6 ip) port
            . s
    fibers:run-server handler-with-path #:family AF_INET6
      . #:port port #:addr (inet-pton AF_INET6 ip) #:socket s

{{{rest-handler-impl}}}
{{{rest-handler}}}

;; the server with handlers and a fallback
define : rest-server ip port
    define : handler-with-path request body
        define method : request-method request
        define path : uri-path : request-uri request
        define handler : find-handler method path
        if handler
            let-values : : (headers body) : handler request body
                values headers body
            values
                build-response
                  . #:headers `((content-type . (text/plain)))
                  . #:code 404
                . "404 not found"
    if : string-contains ip ":"
         run-ipv6-fibers-server handler-with-path ip port
         run-ipv4-fibers-server handler-with-path ip port
    . #f

;; start the server
rest-server "::" 8080

import : ice-9 pretty-print

define : fizzbuzz n
  define : divisible m
    zero? : modulo n m
  define by3 : divisible 3
  define by5 : divisible 5
  cond
    : and by3 by5
      . 'Fizzbuzz
    by3 'Fizz
    by5 'Buzz
    else n

for-each pretty-print : map fizzbuzz : iota 15 1

apply map list '((1 2) (1 3))

define-handler 'GET "/health" : get-health-handler request body
   ...

define-handler 'GET "/health" : get-health-handler request body
        . "Health check.

        Endpoint: /health

        Example: GET /health
                 => OK"
        values
            build-response
                . #:headers `((content-type . (text/plain)))
            . "OK"

define : run-ipv4-server handler-with-path ip port
    run-server handler-with-path 'http `(#:host "localhost"
                                         #:family ,AF_INET
                                         #:addr ,INADDR_ANY
                                         #:port ,port)

define : run-ipv6-server handler-with-path ip port
    define s
        let : : s : socket AF_INET6 SOCK_STREAM 0
            setsockopt s SOL_SOCKET SO_REUSEADDR 1
            bind s AF_INET6 (inet-pton AF_INET6 ip) port
            . s
    run-server handler-with-path 'http `(#:family ,AF_INET6
                                         #:addr (inet-pton AF_INET6 ip)
                                         #:port ,port
                                         #:socket ,s)

define : run-server ip port
    define : handler-with-path request body
        define method : request-method request
        define path : uri-path : request-uri request
        define handler : find-handler method path
        if handler
            let-values : : (headers body) : handler request body wotstate
                values headers body
            values
                build-response
                  . #:headers `((content-type . (text/plain)))
                  . #:code 404
                . "404 not found"

    define ipv6 : string-contains ip ":"
    format : current-error-port
           if ipv6
               . "Started server on http://[~a]:~d\n"
               . "Started server on http://~a:~d\n"
           . ip port
    if ipv6
         run-ipv6-server handler-with-path ip port
         run-ipv4-server handler-with-path ip port
    . #f