summaryrefslogtreecommitdiff
path: root/plugins/zyklonb/calc
diff options
context:
space:
mode:
authorPřemysl Eric Janouch <p@janouch.name>2021-08-06 16:12:15 +0200
committerPřemysl Eric Janouch <p@janouch.name>2021-08-06 16:43:59 +0200
commit50057d5149dda340b3b47aca4096f4a6ec66b9ee (patch)
tree79323d20b17c2c8e32942a1ac9b84d9da3041c6d /plugins/zyklonb/calc
parent1f64710e795b0c5434d15813d4f1f568467ca087 (diff)
downloadxK-50057d5149dda340b3b47aca4096f4a6ec66b9ee.tar.gz
xK-50057d5149dda340b3b47aca4096f4a6ec66b9ee.tar.xz
xK-50057d5149dda340b3b47aca4096f4a6ec66b9ee.zip
Come up with sillier names for the binaries
I'm not entirely sure, but it looks like some people might not like jokes about the Holocaust. On a more serious note, the project has become more serious over the 7 or so years of its existence.
Diffstat (limited to 'plugins/zyklonb/calc')
-rwxr-xr-xplugins/zyklonb/calc241
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)))