diff options
| -rwxr-xr-x | plugins/zyklonb/calc | 236 |
1 files changed, 236 insertions, 0 deletions
diff --git a/plugins/zyklonb/calc b/plugins/zyklonb/calc new file mode 100755 index 0000000..e2f4be9 --- /dev/null +++ b/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))) |