~melchizedek6809/WolkenWelten

ref: 6d229600f745dbd4bd087f01a5fc06f58422b0de WolkenWelten/web/template.scm -rw-r--r-- 4.2 KiB
6d229600Ben (X13/Arch) Alot of fixes, mostly regarding animals and UI 9 months ago
                                                                                
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
(use-modules (ice-9 ftw))

(define (rgb r g b) (list r g b))
(define (rgb* v f) (map (λ (a) (* a f)) v))
(define (rgb+ a b) (if (or (nil? a) (nil? b)) '() (cons (+ (car a) (car b)) (rgb+ (cdr a) (cdr b)))))
(define (rgb->css v) (string-append "rgb("
		(number->string (floor   (car v))) ","
		(number->string (floor  (cadr v))) ","
		(number->string (floor (caddr v))) ")"))

(define (rgb-interpolate a b f) (rgb+ (rgb* a (- 1.0 f)) (rgb* b f)))

(define (filesize path) (stat:size (stat path)))

(define (baseSF path) path)
(define (baseSFS path) path)
(define (hyper text)
	(let* ((tlen (string-length text)) (f 0.0) (i 0))
  (apply string-append (map (λ (v)
	(set! f (/ i tlen)) (set! i (+ 1 i))
	(string-append "<span style=\"color:" (rgb->css (rgb-interpolate (rgb 200 30 100) (rgb 100 200 30) f)) ";\">" (string v) "</span>")) (string->list text)))))


(define (get-newest-release-link arch branch)
	(let* ((prefix (string-append "wolkenwelten-" arch "-" branch)) (p-len (string-length prefix)))
		(string-append "releases/" arch "/" (car (last-pair (scandir (string-append "releases/" arch) (λ (path) (and (>= (string-length path) p-len) (string=? prefix (substring path 0 p-len))))))))))

(define (get-release-path-date path)
	(let* ((lst (string-split path #\-)) (len (length lst)))
		(format #nil "~a-~a-~a" (list-ref lst (- len 4)) (list-ref lst (- len 3)) (list-ref lst (- len 2)))))

(define (human-file-size bytes)
	(cond  [(> bytes (expt 2 20)) (format #nil "~0,1fMB" (/ bytes (expt 2 20)))]
               [(> bytes (expt 2 10)) (format #nil "~0,1fKB" (/ bytes (expt 2 10)))]
	       [#t (format #nil "~aB" bytes)]))

(define (get-release-title path)
	(format #nil "Released: ~a - Size: ~a" (get-release-path-date path) (human-file-size (filesize path))))

(define (get-newest-release-download name arch branch)
	(let ((path (get-newest-release-link arch branch)))
	(string-append "<a class=\"button\" href=\"" path "\" download title=\"" (get-release-title path) "\">" "<span class=\"buttonlabel\">" name "</span><span class=\"buttonicon icon-" arch "\"></span></a>")))

(define (stable-releases) "")
(define (experimental-releases)
	(string-append
		(get-newest-release-download "Windows"          "win"           "master")
		(get-newest-release-download "MacOS"            "macos"         "master")
		(get-newest-release-download "GNU/Linux"        "linux-x86_64"  "master")
		(get-newest-release-download "Linux ARM 64-Bit" "linux-aarch64" "master")
		(get-newest-release-download "Linux ARM 32-Bit" "linux-armv7l"  "master")))

(define (read-all path)
  (apply string (call-with-input-file path
		  (lambda (input-port)
		    (let loop ((x (read-char input-port)))
		      (cond
		       ((eof-object? x) '())
		       (#t (begin (cons x (loop (read-char input-port)))))))))))

(define (write-all path string)
  (call-with-output-file path
    (lambda (output-port)
      (display string output-port))))

(define (string-contains-all s1 s2 start)
  (let ((i (string-contains s1 s2 start)))
    (if i (cons i (string-contains-all s1 s2 (+ 1 i))) '())))

(define (zip a b)
  (if (or (null? a) (null? b)) '()
      (cons (cons (car a) (car b)) (zip (cdr a) (cdr b)))))

(define (valid-tag-list? l start)
  (if (null? l) #t (and (< start (caar l)) (< (caar l) (cdar l)) (valid-tag-list? (cdr l) (cdar l)))))

(define (build-string-list str lst start)
  (if (nil? lst)
      (cons (cons (substring str start (string-length str)) '()) '())
      (let* ((c-prefix (substring str start (caar lst)))
	     (c-code   (substring str       (+ 5 (caar lst)) (cdar lst))))
	(cons (cons c-prefix c-code) (build-string-list str (cdr lst) (+ 2 (cdar lst)))))))

(define (eval-list-tags lst)
  (map (λ (v) (if v (string-append (car v) (if (string? (cdr v)) (eval (call-with-input-string (cdr v) read) (interaction-environment)) "")) "")) lst))

(define (html-eval str)
  (let* ((open-i  (string-contains-all str "<?scm" 0))
         (close-i (string-contains-all str "?>" 0))
         (lst     (zip open-i close-i)))
    (unless (eq? (length open-i) (length close-i)) (display "Warning: Open and Close Tags do not seem to match!\n"))
    (if (valid-tag-list? lst 0) (apply string-append (eval-list-tags (build-string-list str lst 0))) str)))

(define (build)
  (write-all "index.html" (html-eval (read-all "template.html"))))

(build)