xK/plugins/zyklonb/calc

237 lines
9.5 KiB
Scheme
Executable File

#!/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)))