suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Using a language makes this much cuter. Also use base64.

Browse Source 
svn: r17240

original commit: 539519bdad75e2fc8522526017bbec91237403db
This commit is contained in:
Eli Barzilay 2009-12-08 07:02:22 +00:00
parent 6cfcc75248
commit 361027eb87
3 changed files with 84 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/framework/private/bday.ss
View File

@ -1,40 +1,32 @@
#lang scheme/base
(require "decode.ss")
(decode
\5d8f4
\10ec22010
\45aff297b02
\0 \69d544
\5da867
\299da9
\360a3
\5404db
\cbde0b
\4b571f
\7798f6
\13ecaf
\2b5f75
\0cf30bc
\7a62b8d0
\194bcdfb
\023787789
\f02\5b091a
\8ab \8eb3d4
\3a9 \02e040
\3ac \307a74
\ca8 \495944
\6e0 \74fd1
\9ce5 \d88e21
\b04 \f66c25
\a97f \b8d27a
\813 \be13c6
\0d3e \dd50a2
\86d3 \3f5ede
\174a \3235ad9
\ecb40 \2aecb1
\ad56 \76292fb
\6aeb0 \39ae75f
\8f335 \ea955
\e7e \2c7
#lang s-exp framework/private/decode
||\6||\8||\7||\4||\3||\d||\e||\f||\c||\0||\1)
XY9BD
sIgEEWv
8pfMgqRV
E3Whn
qXtT
GOjg
AE08
fYWp
62Nu
897D
PMxjx
heAwtc
7G3Lzfs
CN4 d0m
4K0G giGp
R+8w JgC4
MA0w rvkk
XCTR 5GkC
56T Peux
e8Yo PtsJ
E5X7 jWeY
E74T 1gWf
ryiR 4OjH
y/tK Waem
1XMZ aIU9
ttXK LuXV
1hU2 x7WO
f75G vdLLj
9Xuc CD6A
\\\\ A==

31
collects/framework/private/decode.ss
View File

@ -1,20 +1,19 @@
#lang scheme/base
(require (for-syntax file/gunzip scheme/base))
(provide decode)
(require (for-syntax scheme/base file/gunzip net/base64))
(provide (except-out (all-from-out scheme/base) #%module-begin)
(rename-out [module-begin #%module-begin]))
(define-syntax (decode stx)
(define (decode stxs)
(define str
(apply string-append (map (λ (x) (symbol->string (syntax-e x))) stxs)))
(define loc
(if (even? (string-length str))
(for/list ([i (in-range 0 (string-length str) 2)])
(string->number (substring str i (+ i 2)) 16))
(error 'decode "missing digit somewhere")))
(define-values (p-in p-out) (make-pipe))
(inflate (open-input-bytes (apply bytes loc)) p-out)
(read p-in))
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ x ...)
(andmap identifier? (syntax->list #'(x ...)))
(datum->syntax stx (decode (syntax->list #'(x ...))) stx)]))
(andmap (lambda (x) (or identifier? (integer? (syntax-e x))))
(syntax->list #'(x ...)))
(let* ([data (format "~a" (syntax->datum #'(x ...)))]
[data (substring data 1 (sub1 (string-length data)))]
[data (string->bytes/utf-8 data)]
[in (open-input-bytes (base64-decode data))]
[out (open-output-string)]
[out (begin (inflate in out) (get-output-string out))]
[exprs (read (open-input-string (string-append "(" out ")")))]
[exprs (datum->syntax stx exprs stx)])
#`(#%module-begin #,@exprs))]))

100
collects/framework/private/encode.ss
View File

@ -1,67 +1,43 @@
#lang scheme/base
(require mzlib/deflate
mzlib/match
mzlib/pretty)
(require (for-syntax mzlib/inflate
mzlib/string))
(require scheme/cmdline scheme/string scheme/match scheme/pretty
file/gzip file/gunzip net/base64)
(provide encode-sexp
encode-module)
(define (encode-exprs exprs)
(define in
(open-input-string
(string-join (map (lambda (x) (format "~s" x)) exprs) " ")))
(define out (open-output-bytes))
(deflate in out)
(base64-encode (get-output-bytes out)))
(define (encode-module in-filename out-filename)
(call-with-input-file in-filename
(λ (port)
(let ([mod (read port)])
(unless (eof-object? (read port))
(error 'encode-module "found an extra expression"))
(match mod
[`(module ,m mzscheme ,@(bodies ...))
(call-with-output-file out-filename
(λ (oport)
(let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))])
(fprintf oport "(module ~a mzscheme\n" m)
(fprintf oport " (require framework/private/decode)\n")
(fprintf oport " (decode ~a" (car chopped))
(for-each (lambda (chopped)
(fprintf oport "\n ~a" chopped))
(cdr chopped))
(fprintf oport "))\n")))
'truncate 'text)]
[else (error 'encode-module "cannot parse module")])))))
(define (encode-module)
(define mod (parameterize ([read-accept-reader #t]) (read)))
(when (eof-object? mod) (error 'encode-module "missing module"))
(match mod
[(list 'module m 'scheme/base (list '#%module-begin exprs ...))
(write-bytes #"#lang s-exp framework/private/decode\n")
(write-bytes (regexp-replace* #rx"\r\n" (encode-exprs exprs) #"\n"))]
[else (error 'encode-module "cannot parse module, must use scheme/base")]))
(define (chop-up sym)
(let ([chopping-point 50])
(let loop ([str (symbol->string sym)])
(cond
[(<= (string-length str) chopping-point)
(list (string->symbol str))]
[else
(cons (string->symbol (substring str 0 chopping-point))
(loop (substring str chopping-point (string-length str))))]))))
(define (decode-module)
(define mod (parameterize ([read-accept-reader #t]) (read)))
(when (eof-object? mod) (error 'encode-module "missing module"))
(match mod
[(list 'module m 'framework/private/decode
(list '#%module-begin exprs ...))
(write-bytes #"#lang scheme/base\n")
(let* ([data (format "~a" exprs)]
[data (substring data 1 (sub1 (string-length data)))]
[data (string->bytes/utf-8 data)]
[in (open-input-bytes (base64-decode data))]
[out (open-output-string)]
[out (begin (inflate in out) (get-output-string out))]
[exprs (read (open-input-string (string-append "(" out ")")))])
(for ([expr (in-list exprs)])
(pretty-print expr)))]
[else (error 'decode-module "cannot parse module, must use scheme/base")]))
(define (encode-sexp sexp)
(define (str->sym string)
(string->symbol
(apply
string-append
(map
(λ (x)
(to-hex x))
(bytes->list string)))))
(define (to-hex n)
(let ([digit->hex
(λ (d)
(cond
[(<= d 9) d]
[else (integer->char (+ d -10 (char->integer #\a)))]))])
(cond
[(< n 16) (format "0~a" (digit->hex n))]
[else (format "~a~a"
(digit->hex (quotient n 16))
(digit->hex (modulo n 16)))])))
(let ([in (open-input-string (format "~s" sexp))]
[out (open-output-bytes)])
(deflate in out)
(str->sym (get-output-bytes out))))
(command-line #:once-any
["-e" "encode" (encode-module) (exit)]
["-d" "decode" (decode-module) (exit)])
(printf "Use `-h' for help\n")