ZyklonB: add a calc plugin

plugins/zyklonb/calc

@@ -0,0 +1,236 @@
+#!/usr/bin/env guile
+
+  ZyklonB calc plugin, basic Scheme evaluator
+
+  Copyright 2016 Přemysl Janouch
+  See the file LICENSE for licensing information.
+
+!#
+
+(import (rnrs (6)))
+(use-modules ((rnrs) :version (6)))
+
+; --- Message parsing ----------------------------------------------------------
+
+(define-record-type message (fields prefix command params))
+(define (parse-message line)
+  (let f ([parts '()] [chars (string->list line)])
+    (define (take-word w chars)
+      (if (or (null? chars) (eqv? (car chars) #\x20))
+        (f (cons (list->string (reverse w)) parts)
+           (if (null? chars) chars (cdr chars)))
+        (take-word (cons (car chars) w) (cdr chars))))
+    (if (null? chars)
+      (let ([data (reverse parts)])
+        (when (< (length data) 2)
+          (error 'parse-message "invalid message"))
+        (make-message (car data) (cadr data) (cddr data)))
+      (if (null? parts)
+        (if (eqv? (car chars) #\:)
+          (take-word '() (cdr chars))
+          (f (cons #f parts) chars))
+        (if (eqv? (car chars) #\:)
+          (f (cons (list->string (cdr chars)) parts) '())
+          (take-word '() chars))))))
+
+; --- Utilities ----------------------------------------------------------------
+
+(define (display-exception e port)
+  (define (puts . x)
+    (for-all (lambda (a) (display a port)) x)
+    (newline port))
+
+  (define (record-fields rec)
+    (let* ([rtd (record-rtd rec)]
+           [v (record-type-field-names rtd)]
+           [len (vector-length v)])
+      (map (lambda (k i) (cons k ((record-accessor rtd i) rec)))
+        (vector->list v)
+        (let c ([i len] [ls '()])
+          (if (= i 0) ls (c (- i 1) (cons (- i 1) ls)))))))
+
+  (puts "Caught " (record-type-name (record-rtd e)))
+  (for-all
+    (lambda (subtype)
+      (puts "  " (record-type-name (record-rtd subtype)))
+      (for-all
+        (lambda (field) (puts "    " (car field) ": " (cdr field)))
+        (record-fields subtype)))
+    (simple-conditions e)))
+
+; XXX - we have to work around Guile's lack of proper eol-style support
+(define xc (make-transcoder (latin-1-codec) 'lf 'replace))
+(define irc-input-port (transcoded-port (standard-input-port) xc))
+(define irc-output-port (transcoded-port (standard-output-port) xc))
+
+(define (send . message)
+  (for-all (lambda (x) (display x irc-output-port)) message)
+  (display #\return irc-output-port)
+  (newline irc-output-port)
+  (flush-output-port irc-output-port))
+
+(define (get-line-crlf port)
+  (define line (get-line port))
+  (if (eof-object? line) line
+    (let ([len (string-length line)])
+      (if (and (> len 0) (eqv? (string-ref line (- len 1)) #\return))
+        (substring line 0 (- len 1)) line))))
+
+(define (get-config name)
+  (send "ZYKLONB get_config :" name)
+  (car (message-params (parse-message (get-line-crlf irc-input-port)))))
+
+(define (extract-nick prefix)
+  (do ([i 0 (+ i 1)] [len (string-length prefix)])
+      ([or (= i len) (char=? #\! (string-ref prefix i))]
+       [substring prefix 0 i])))
+
+(define (string-after s start)
+  (let ([s-len (string-length s)] [with-len (string-length start)])
+    (and (>= s-len with-len)
+         (string=? (substring s 0 with-len) start)
+         (substring s with-len))))
+
+; --- Calculator ---------------------------------------------------------------
+
+; Evaluator derived from the example in The Scheme Programming Language
+
+(define (env-new formals actuals env)
+  (cond [(null? formals) env]
+        [(symbol? formals) (cons (cons formals actuals) env)]
+        [else (cons (cons (car formals) (car actuals))
+                    (env-new (cdr formals) (cdr actuals) env))]))
+(define (env-lookup var env) (cdr (assq var env)))
+(define (env-assign var val env) (set-cdr! (assq var env) val))
+
+(define (check-reductions r)
+  (if (= (car r) 0)
+    (error 'check-reductions "reduction limit exceeded")
+    (set-car! r (- (car r) 1))))
+
+; TODO - think about implementing more syntactical constructs
+(define (exec expr r env)
+  (check-reductions r)
+  (cond [(symbol? expr) (env-lookup expr env)]
+        [(pair? expr)
+         (case (car expr)
+           [(quote) (cadr expr)]
+           [(lambda) (lambda vals
+                       (let ([env (env-new (cadr expr) vals env)])
+                         (let loop ([exprs (cddr expr)])
+                           (if (null? (cdr exprs))
+                             (exec (car exprs) r env)
+                             (begin (exec (car exprs) r env)
+                                    (loop (cdr exprs)))))))]
+           [(if) (if (exec (cadr expr) r env)
+                   (exec (caddr expr) r env)
+                   (exec (cadddr expr) r env))]
+           [(set!) (env-assign (cadr expr) (exec (caddr expr) r env) env)]
+           [else (apply (exec (car expr) r env)
+                        (map (lambda (x) (exec x r env)) (cdr expr)))])]
+        [else expr]))
+
+(define-syntax forward
+  (syntax-rules ()
+    [(_) '()]
+    [(_ a b ...) (cons (cons (quote a) a) (forward b ...))]))
+
+(define base-library
+  (forward
+    ; Equivalence, procedure predicate, booleans
+    eqv? eq? equal? procedure? boolean? boolean=? not
+    ; numbers, numerical input and output
+    number? complex? real? rational? integer?  exact? inexact? exact inexact
+    real-valued? rational-valued? integer-valued? number->string string->number
+    ; Arithmetic
+    = < > <= >= zero? positive? negative? odd? even? finite? infinite? nan?
+    min max + * - / abs div-and-mod div mod div0-and-mod0 div0 mod0
+    gcd lcm numerator denominator floor ceiling truncate round
+    rationalize exp log sin cos tan asin acos atan sqrt expt
+    make-rectangular make-polar real-part imag-part magnitude angle
+    ; Pairs and lists
+    map for-each cons car cdr caar cadr cdar cddr
+    caaar caadr cadar caddr cdaar cdadr cddar cdddr
+    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+    pair? null? list? list length append reverse list-tail list-ref
+    ; Symbols
+    symbol? symbol=? symbol->string string->symbol
+    ; Characters
+    char? char=? char<? char>? char<=? char>=?  char->integer integer->char
+    ; Strings; XXX make-string can make an arbitrary length string -> removed
+    string? string=? string<? string>? string<=? string>=?
+    make-string string string-length string-ref substring
+    string-append string->list list->string string-for-each string-copy
+    ; Vectors; XXX make-vector can make an arbitrary length vectors -> removed
+    vector? make-vector vector vector-length vector-ref vector-set!
+    vector->list list->vector vector-fill! vector-map vector-for-each
+    ; Control features
+    apply call/cc values call-with-values dynamic-wind))
+(define extended-library
+  (forward
+    char-upcase char-downcase char-titlecase char-foldcase
+    char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
+    char-alphabetic? char-numeric? char-whitespace?
+    char-upper-case? char-lower-case? char-title-case?
+    string-upcase string-downcase string-titlecase string-foldcase
+    string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
+    find for-all exists filter partition fold-left fold-right
+    remp remove remv remq memp member memv memq assp assoc assv assq cons*
+    list-sort vector-sort vector-sort!
+    bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-if
+    bitwise-bit-count bitwise-length bitwise-first-bit-set bitwise-bit-set?
+    bitwise-copy-bit bitwise-bit-field bitwise-copy-bit-field
+    bitwise-arithmetic-shift bitwise-rotate-bit-field bitwise-reverse-bit-field
+    bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
+    set-car! set-cdr! string-set! string-fill!))
+(define (interpret expr)
+  (exec expr '(2000) (append base-library extended-library)))
+
+; We could show something a bit nicer but it would be quite Guile-specific
+(define (error-string e)
+  (map (lambda (x) (string-append " " (symbol->string x)))
+    (filter (lambda (x) (not (member x '(&who &message &irritants &guile))))
+      (map (lambda (x) (record-type-name (record-rtd x)))
+        (simple-conditions e)))))
+
+(define (calc input respond)
+  (define (stringify x)
+    (call-with-string-output-port (lambda (port) (write x port))))
+  (guard (e [else (display-exception e (current-error-port))
+                  (apply respond "caught" (error-string e))])
+    (let* ([input (open-string-input-port input)]
+           [data (let loop ()
+                   (define datum (get-datum input))
+                   (if (eof-object? datum) '() (cons datum (loop))))])
+      (call-with-values
+        (lambda () (interpret (list (append '(lambda ()) data))))
+        (lambda message
+          (for-all (lambda (x) (respond (stringify x))) message))))))
+
+; --- Main loop ----------------------------------------------------------------
+
+(define prefix (get-config "prefix"))
+(send "ZYKLONB register")
+
+(define (process msg)
+  (when (string-ci=? (message-command msg) "PRIVMSG")
+    (let* ([nick (extract-nick (message-prefix msg))]
+           [target (car (message-params msg))]
+           [response-begin
+             (apply string-append "PRIVMSG "
+               (if (memv (string-ref target 0) (string->list "#&!+"))
+                 `(,target " :" ,nick ": ") `(,nick " :")))]
+           [respond (lambda args (apply send response-begin args))]
+           [text (cadr (message-params msg))]
+           [input (or (string-after text (string-append prefix "calc "))
+                      (string-after text (string-append prefix "= ")))])
+      (when input (calc input respond)))))
+
+(let main-loop ()
+  (define line (get-line-crlf irc-input-port))
+  (unless (eof-object? line)
+    (guard (e [else (display-exception e (current-error-port))])
+      (unless (string=? "" line)
+        (process (parse-message line))))
+    (main-loop)))