first version of barchart and also all.rkt

cmd/lines.rkt

@@ -3,7 +3,7 @@
 (require racket/cmdline)
 (require racket/file)
 
-(require "../utils/misc.rkt")
+(require "../utils/base.rkt")
 
 ;; count lines of code in the project
 

examples/carmichael/main.rkt

 #lang racket
 
-(require "../../lib/seqs.rkt")
-(require "../../lib/utils.rkt")
+(require "../../utils/seqs.rkt")
+(require "../../utils/base.rkt")
 
 ;; Fermat's little theorem illustration for different numbers from 1 to 1000
 ;; with Carmichael numbers (at least 561)

graphics/color.rkt

 #lang racket
 
 (require "../utils/seqs.rkt")
-(require "../utils/misc.rkt")
+(require "../utils/base.rkt")
+(require "../utils/controls.rkt")
 
 ;(require dshirshov/utils)
 ;(require dshirshov/seqs)

graphics/svg.rkt

@@ -2,9 +2,9 @@
 
 (require racket/file)
 (require (for-syntax racket/syntax))
-(require "../utils/misc.rkt" (for-syntax "../utils/misc.rkt"))
+(require "../utils/base.rkt" (for-syntax "../utils/base.rkt"))
 (require "../utils/hash.rkt")
-(require "../utils/seqs.rkt")
+(require "../utils/seqs.rkt" (for-syntax "../utils/seqs.rkt"))
 (require compatibility/defmacro)
 
 (provide (all-defined-out))
@@ -22,14 +22,18 @@
         [body (if (empty? body) "" (apply string-append body))])
     (format "<svg~a~a>~a</svg>" xmlns xlink body)))
 
-;; 1. +TODO: define-syntax: if first tag in body is (attr  ...) then do (g (attrs (hash)) . body), else (g . body)
-;; 2. +TODO: print all arbitrary attributes from the given hash-table (text (attr 'x 10 'y 10 'foobar "baz") (tspan ... ) ...)
-;; 3. +TODO: make this more generalized: (define-syntax (make-tag <tagname>)) -> (define-syntax (<tagname> stx) ...)
-;; (make-tag "g") (make-tag "text")
 
+; e.g.: (rect x 10 y 10 width 100 height 100) as well as (rect 'x 10 'y 10 'width 100 'height 100)
 (define-macro (make-single-tag tagname)
-  `(define (,tagname . body)
-      (str "<" (quote ,tagname) (print-hash " ~a=\"~a\"" (apply hash body)) "/>")))
+  `(define-macro (,tagname . body)
+    (define (odd-f f lst)
+      (cond
+        ((null? lst) null)
+        ((null? (cadr lst)) (cdr lst))
+        (else (cons (f (car lst)) (cons (cadr lst) (odd-f f (cddr lst)))))))
+    (let ([nbody (odd-f (λ(x) (if (symbol? x) (symbol->string x) x)) body)]
+          [t (symbol->string (quote ,tagname))])
+      `(str "<" ,t (print-hash " ~a=\"~a\"" (hash ,@nbody)) " />"))))
 
 (define-syntax (make-tag stx)
   (let ((tagname (symbol->string (list-ref (syntax->datum stx) 1))))

graphics/svg_test.rkt

 #lang racket
 
-; TODO:
-; + fix 'find end-of-file error' when running 'raco test spec.rkt'
-; - make rand-color function as short as original one in newlisp
-; - related to previous: learn analogs for reduce, and other javascript functions that were handy in working with arrays and strings, if no direct analog, and no handy substitution - implement this function in utils.rkt
-
 (module+ test
 
   (require rackunit)
   (require "svg.rkt")
-
-  ; SVG
-  ; (svg
-    ;(g
-      ;(rect #:x 10 #:y 10 #:width 100 #:height 150 #:fill "red")
-      ;(rect #:x 10 #:y 10 #:width 100 #:height 150 #:fill "red")))
+  (require "../utils/base.rkt")
+  (require "../utils/seqs.rkt")
+  (require "../utils/hash.rkt")
 
   (check-equal?
     (svg)
+    (rtrim ; remove \r at the end of the string
     #<<svg
 <svg></svg>
 svg
-  )
+  ))
 
   (check-equal?
-    (svg #:xmlns #t)
+    (svg (@ 'xmlns #t))
+    (rtrim
     #<<svg
 <svg xmlns="http://www.w3.org/2000/svg"></svg>
 svg
-  )
+  ))
 
   (check-equal?
-    (svg #:xmlns #t #:xlink #t)
+    (svg (@ 'xmlns #t 'xlink #t))
+    (rtrim
     #<<svg
 <svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink"></svg>
 svg
-  )
-
-  (check-equal?
-    (svg
-      (g
-        (rect #:x 10 #:y 10 #:width 100 #:height 150 #:fill "red")
-        (rect #:x 100 #:y 400 #:width 200 #:height 300 #:fill "cyan")))
-    #<<svg
-<svg xmlns="http://www.w3.org/2000/svg">
-<g>
-<rect x='10' y='10' width='100' height='150' fill='red' />
-<rect x='100' y='400' width='200' height='300' fill='cyan' />
-</g>
-</svg>
-svg
-  )
+  ))
 
-  ; G
-  ; (g #:id "external" (g #:id "inner" (rect #:x 10 #:y 10 #:width 100 #:height 150 #:fill "red")))
+  (check-equal? (g) "<g></g>")
+  (check-equal? (g (g)) "<g><g></g></g>")
+  (check-equal? (g (@ 'id "id0") (g)) "<g id=\"id0\"><g></g></g>")
 
+  (check-equal? (g (rect x 10)) "<g><rect x=\"10\" /></g>")
+  (check-equal? (string-length (g (rect x 10 y 10 width 100 height 100))) (string-length "<g><rect x=\"10\" y=\"10\" width=\"100\" height=\"100\" /></g>"))
 
+  ; simple case
   (check-equal?
-    (g "hello world! "
-      (rect #:x 10
-            #:y 10
-            #:width 100
-            #:height 150
-            #:fill "red"))
-    "<g>hello world! <rect x='10' y='10' width='100' height='150' fill='red' />\r\n</g>\r\n")
-
-
-  ; RECT
-  ; (rect #:x 10 #:y 10 #:width 100 #:height 150 #:fill "red")
+    (string-length
+      (svg (@)
+        (g
+          (rect x 10 y 10 width 100 height 150 fill "red" data-comment "rect in the simple case"))))
+    (string-length (rtrim
+    #<<svg
+<svg><g><rect x="10" y="10" width="100" height="150" fill="red" data-comment="rect in the simple case" /></g></svg>
+svg
+  )))
 
+  ;; more complex case
   (check-equal?
-    (rect #:width 100
-          #:x 10
-          #:y 10
-          #:height 150)
-    "<rect x=\"10\" y=\"10\" width=\"100\" height=\"150\" fill=\"black\" />\r\n")
-  (check-equal?
-    (rect #:x (* (sqrt 4) 100)
-          #:y 10
-          #:width 100
-          #:height 150
-          #:fill "red")
-    "<rect x=\\"200\\" y=\\"10\\" width=\\"100\\" height=\\"150\\" fill=\\"red\\" />\r\n")
-
-;  ;; ANY TAG, ANY ATTRIBUTE (how to use racket functions then?)
-;  (check-equal?
-;    (foobar #:foo 10 #:bar "hello"
-;      (fooqux #:id "qux" #:quux 100)
-;      (foobaz
-;        (fooquux #:id "fooquux" "hello world!")
-;        #:id "foobaz_id" #:pid 3300)
-;      (fooquxbaz "Autumn!"))
-;#<<svg
-;<foobar foo="10" bar="hello">
-;<fooqux id="qux" quux="100" />
-;<foobaz id="foobaz_id" pid="3300">
-;<fooquux id="fooquux">hello world!<fooquux>
-;</foobaz>
-;<fooquxbaz>Autumn!</fooquxbaz>
-;</foobar>
-;svg
-;  )
-
+    (string-length
+      (svg (@ 'xmlns #t)
+        (g)
+        (g (@ 'id "group1")
+          (rect x 10 y 10 width 100 height 150 fill "green")
+          (g (g (@ 'id "subgroup1") (g (rect x 100 y 400 width 200 height 300)))))))
+    (string-length (rtrim
+    #<<svg
+<svg xmlns="http://www.w3.org/2000/svg"><g></g><g id="group1"><rect x="10" y="10" width="100" height="150" fill="green" /><g><g id="subgroup1"><g><rect x="100" y="400" width="200" height="300" /></g></g></g></g></svg>
+svg
+  )))
 )

test.rkt

 #lang racket
 
-(require "scrap/file.rkt")
-(require "utils/seqs.rkt")
+(require "utils/all.rkt")
 
-;(write-file "scrap/test.txt" "a;b\n100;200")
-;(print (nth (read-csv-file "scrap/test.txt") 1))
-
-;(print (slice (read-file "examples/dna/e.coli_0157.gbk") 2 12))
-
-;(print (substring (read-file "examples/dna/e.coli_0157.gbk") 2 12))
-
-;(define gene-block (pregexp "(?sm:CDS.*?gene)"));(?=^\\s*gene))"))
-;
-;(print (regexp-match gene-block (read-file "examples/dna/e.coli_0157.gbk")))
-
-;(require "graphics/svg.rkt")
-;
-;(print
-;  (svg
-;    (svg-g (svg-g) (svg-foobar (svg-ract)))))
-
-(require (for-syntax racket/syntax racket/string))
-
-(define-syntax (hyphen-define* stx)
-  (syntax-case stx ()
-    [(_ (names ...) (args ...) body0 body ...)
-      (let*
-        ( [names/sym (map syntax-e (syntax->list #'(names ...)))]
-          [names/str (map symbol->string names/sym)]
-          [name/str (string-join names/str "-")]
-          [name/sym (string->symbol name/str)])
-            (with-syntax
-              ([name (datum->syntax stx name/sym)])
-              #'(define (name args ...) body0 body ...)))]))
+(nth '(1 2 3 4 5) 2)

utils/all.rkt

+#lang racket
+
+(require "base.rkt" "controls.rkt" "hash.rkt" "io.rkt" "iter.rkt" "seqs.rkt" "time.rkt")
+
+(provide (all-from-out "base.rkt" "controls.rkt" "hash.rkt" "io.rkt" "iter.rkt" "seqs.rkt" "time.rkt"))

utils/misc.rkt → utils/base.rkt

@@ -6,9 +6,16 @@
 
 (define % remainder)
 
+(define dec sub1)
+
+(define inc add1)
+
 (define (// a b)
   (exact->inexact (/ a b)))
 
+(define (/r a b)
+  (round (/ a b)))
+
 (define (*r . xs)
   (exact-round (apply * xs)))
 
@@ -43,20 +50,14 @@
 (define (rcurry f a)
   (lambda (x) (f x a)))
 
-; (gen (random 100) 10) -> '(1 34 50 7 80 62 58 91 10 8)
-(define-macro (gen f size)
-  `(let ((n ,size))
-    (define (gen-r count)
-      (cond
-        ((= count 1) (list ,f))
-        (else (cons ,f (gen-r (- count 1))))))
-    (gen-r n)))
+(define (clean f xs)
+  (filter (λ (x) (not (f x))) xs))
 
 (define (rand n)
   (add1 (random n))) ;; STX random
 
 ; cyclic addition (e.g. for finding contrast values on color circle)
-(define (cycadd a b base)
+(define (+c a b base)
   (let ((factor
           (if (or (inee 0 1 a) (inee 0 1 b))
             (/ 1 (min a b))
@@ -67,25 +68,6 @@
         base))
       factor)))
 
-; ((-> floor sqrt random) 10)
-(define (-> . fs)
-  (define (call-r fs x)
-    (cond
-      ((empty? fs) x)
-      (else ((car fs) (call-r (cdr fs) x)))))
-  (λ (x)
-    (call-r fs x)))
-
-; (->> floor sqrt random 10)
-(define (->> . fs)
-  (cond
-    ((empty? (cdr fs)) (car fs))
-    (else
-      ((car fs) (apply ->> (cdr fs))))))
-
-(define (clean f xs)
-  (filter (λ (x) (not (f x))) xs))
-
 (define (syntax->string stx)
   (let ((el (syntax->datum stx)))
     (cond

utils/controls.rkt

+#lang racket
+
+(require compatibility/defmacro)
+
+(provide (all-defined-out))
+
+; ((-> floor sqrt random) 10)
+(define (-> . fs)
+  (define (call-r fs x)
+    (cond
+      ((empty? fs) x)
+      (else ((car fs) (call-r (cdr fs) x)))))
+  (λ (x)
+    (call-r fs x)))
+
+; (->> floor sqrt random 10)
+(define (->> . fs)
+  (cond
+    ((empty? (cdr fs)) (car fs))
+    (else
+      ((car fs) (apply ->> (cdr fs))))))
+
+; (gen (random 100) 10) -> '(1 34 50 7 80 62 58 91 10 8)
+(define-macro (gen f size)
+  `(let ((n ,size))
+    (define (gen-r count)
+      (cond
+        ((= count 1) (list ,f))
+        (else (cons ,f (gen-r (- count 1))))))
+    (gen-r n)))
+
+; (define (foo n) (nlet foo-iter (x y) (cond ... (else (foo-iter (add1 x) (sub1 y))))) (foo-iter 0 n))
+;(define-macro (nlet n letargs . body)
+;  `(define (,n ,@letargs)
+;      ,@body))

utils/hash.rkt

 #lang racket
 
+(require compatibility/defmacro)
+(require (for-syntax ))
+
 (provide (all-defined-out))
 
 (define (map/hash f h)
@@ -13,3 +16,7 @@
     ([res ""])
     ([(k v) (in-hash h)])
     (string-append res (format format-str k v))))
+
+(define-macro (hash-sym . body)
+  (let ((nbody (map (λ(x) (if (symbol? x) (symbol->string x) x)) body)))
+    `(hash ,@nbody)))

utils/iter.rkt

+#lang racket
+
+(provide (all-defined-out))
+
+(define-syntax (for/fold/idx stx)
+  (syntax-case stx ()
+    [(_ (s start-value) (i sequence) body)
+      (datum->syntax stx
+        `(for/fold
+          ([s ,#'start-value])
+          ([,#'i ,#'sequence] [$idx (range (length ,#'sequence))])
+          ,#'body))
+    ]))

utils/seqs.rkt

@@ -3,7 +3,8 @@
 (provide (except-out (all-defined-out) c2))
 
 (require compatibility/defmacro)
-(require "misc.rkt")
+(require "base.rkt")
+(require "controls.rkt")
 
 ;; algebra of operations with strings and lists (arrays)
 

utils/time.rkt

@@ -5,7 +5,7 @@
 ;;;; functions to work with time
 
 ;; add hours and minutes
-(define (add-hourly . hs)
+(define (+h . hs)
   (define (rst a) (- a (floor a)))
     (let* ( [intsum (apply + (map floor hs))]
             [fractsum (apply + (map rst hs))]

widgets/barchart.rkt

+#lang racket
+
+;; TODO: (require "../utils/all.rkt") instead of requiring the files one by one
+(require "../graphics/svg.rkt")
+(require "../utils/seqs.rkt")
+(require "../utils/base.rkt")
+(require "../utils/iter.rkt")
+(require "../utils/hash.rkt")
+
+(provide (all-defined-out))
+
+; data ~ '(10 2 -3 46 8)
+; (barchart '(3 4 8 1 9 5))
+(define (barchart data (box '(800 600)) (gap 1) (color "black") (normalize-mode 'trunc-at-zero))
+  (define (normalize data factor)
+    (map factor
+      (case normalize-mode
+        ([min-to-zero]
+          (let* (
+                [data-min (apply min data)]
+                [n-data (if (< data-min 0)
+                                    (map (λ (x) (+ x (abs data-min))) data)
+                                    (map (λ (x) (- x data-min)) data) )])
+            n-data))
+        ([trunc-at-zero]
+          (map (λ (x) (if (< x 0) 0 x)) data))
+        (else data))))
+  (let* (
+        [top-margin 50]
+        [box-w (nth box 1)]
+        [box-h (nth box 2)]
+        [amount (length data)]
+        [bar-w ( { box-w . - . [ amount . * . gap ] } . /r . amount )]
+        [base (+ box-h top-margin)]
+        [data-max (apply max data)]
+        [factor (λ (x) (/ (* x box-h) data-max))])
+    (g
+      (for/fold/idx
+        (s "")
+        (h (normalize data factor))
+          (str s
+              (rect x (* $idx (+ bar-w gap))
+                y (- base h)
+                width bar-w
+                height h))))))