assets.scm (4571B)
1 (define-module (assets) 2 #:export (text-logo logo style archive archive-problems archive-solutions 3 problems rules-text stagit-sources)) 4 (use-modules (srfi srfi-1) 5 (srfi srfi-9) 6 (style) 7 (sxml simple) 8 (ice-9 textual-ports) 9 (ice-9 ftw)) 10 11 (define-record-type <archive-round> 12 (make-archive-round problems solutions) 13 archive-round? 14 (problems archive-problems) 15 (solutions archive-solutions)) 16 17 (define text-logo " 18 __ ___ __ __ _ __ __ 19 / |/ /__ / /_____ / /_ ______ ___ ____ (_)_/_/ ____/ /___ 20 / /|_/ / _ \\/ __/ __ `/ / / / / __ `__ \\/ __ \\/ / __ `/ __ / __ `/ 21 / / / / __/ /_/ /_/ / / /_/ / / / / / / /_/ / / /_/ / /_/ / /_/ / 22 /_/ /_/\\___/\\__/\\__,_/_/\\__, /_/ /_/ /_/ ,___/_/\\__,_/\\__,_/\\__,_/ 23 /____/ /_/ 24 OLYMPIÁDA O METALYMPIÁDE" 25 ) 26 27 (define (list->css lst delimiter) 28 (let ((to-string (lambda (v) (cond ((string? v) v) 29 ((number? v) (number->string v)) 30 ((list? v) (list->css v delimiter))))) 31 (first (car lst))) 32 (if (symbol? first) 33 (string-append (symbol->string first) 34 "(" 35 (if (null? (cdr lst)) "" (list->css (cdr lst) ",")) 36 ")") 37 (fold (lambda (n so-far) (string-append so-far delimiter (to-string n))) 38 (to-string first) 39 (cdr lst))))) 40 41 (define (prop->css prop so-far) 42 (string-append so-far (symbol->string (car prop)) ":" (list->css (cdr prop) " ") ";")) 43 44 (define (sexp->css style) 45 (let* ((style-rule 46 (lambda (source so-far) 47 (let* ((name (car source)) 48 (rest (cdr source)) 49 (first-name (caar rest)) 50 (first-prop (cdar rest))) 51 (if (eq? name '@) 52 (string-append so-far "@" (symbol->string first-name) 53 " " (list->css first-prop " ") "{" 54 (sexp->css (cdr rest)) "}") 55 (if (eq? first-name ':) 56 (string-append so-far (symbol->string name) 57 ":" (list->css first-prop " ") "{" 58 (fold prop->css "" (cdr rest)) "}") 59 (string-append so-far (symbol->string name) "{" 60 (fold prop->css "" rest) "}"))))))) 61 (fold style-rule "" style))) 62 63 (define style (sexp->css stylesheet)) 64 65 (define (logo-generator height ratio iterations) 66 (let ((width (* height ratio))) 67 `(svg (@ (class "logo") (aria-hidden "true") 68 (viewBox ,(list->css `(0 0 ,width ,height) " "))) 69 ,@(map (lambda (i) (let* ((r (expt ratio i)) 70 (w (* width r)) 71 (h (* height r)) 72 (x (/ (- width w) 2))) 73 `(rect (@ (x ,x) (y ,x) (width ,w) (height ,h))))) 74 (iota iterations))))) 75 76 (define logo (logo-generator 500 logo-ratio 11)) 77 78 (define (read-string file) (call-with-input-file file get-string-all)) 79 80 (define archive-dir "archive") 81 82 (define (tild-split file) (string-split (read-string file) #\~)) 83 84 (define archive 85 (let ((text-file (lambda (dir name) 86 (string-append archive-dir "/" dir "/" name)))) 87 (map (lambda (dir) 88 (make-archive-round (tild-split (text-file dir "problems")) 89 (tild-split (text-file dir "solutions")))) 90 (scandir archive-dir (lambda (f) (not (string-every #\. f))))))) 91 92 (define problems (tild-split "texts/problems")) 93 94 (define rules-text (read-string "texts/rules")) 95 96 (define stagit-dir ".stagit") 97 98 (define stagit-sources (make-hash-table)) 99 100 (begin (if (not (file-exists? stagit-dir)) 101 (mkdir stagit-dir)) 102 (chdir stagit-dir) 103 (system "../stagit ..") 104 (chdir "..")) 105 106 (ftw stagit-dir 107 (lambda (name statinfo flag) 108 (if (equal? flag 'regular) 109 (hash-set! stagit-sources 110 (substring name (+ (string-length stagit-dir) 1)) 111 (cdr (xml->sxml (read-string name))))) 112 #t)) 113