diff options
Diffstat (limited to 'plugins/zyklonb/calc')
| -rwxr-xr-x | plugins/zyklonb/calc | 241 |
1 files changed, 0 insertions, 241 deletions
diff --git a/plugins/zyklonb/calc b/plugins/zyklonb/calc deleted file mode 100755 index 8e36357..0000000 --- a/plugins/zyklonb/calc +++ /dev/null @@ -1,241 +0,0 @@ -#!/usr/bin/env guile - - ZyklonB calc plugin, basic Scheme evaluator - - Copyright 2016 Přemysl Eric 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 s-len)))) - -; --- Calculator --------------------------------------------------------------- - -; Evaluator derived from the example in The Scheme Programming Language. -; -; Even though EVAL with a carefully crafted environment would also do a good -; job at sandboxing, it would probably be impossible to limit execution time... - -(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, -; however there's not much point in having anything else in a calculator... -(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 ...))])) - -; ...which can't prevent me from simply importing most of the standard library -(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 - omitted make-string - can cause OOM - string? string=? string<? string>? string<=? string>=? - string string-length string-ref substring - string-append string->list list->string string-for-each string-copy - ; Vectors; XXX - omitted make-vector - can cause OOM - 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))) |