summaryrefslogtreecommitdiff
path: root/plugins/zyklonb/calc
blob: 1df059619f4aac3a316ad1c4fc8331947d9364c5 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
#!/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 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)))