Welcome to the CHICKEN Scheme pasting service

(use srfi-1)
(use ports)

(include "vector3d.scm")
(include "dsum2.scm")
(include "read-stl-2.scm")

(define (fun1 f)
  (let* ((k (/ (* 8.0 (atan 1.0) f) 340.0))
         (ka (* k 0.02))
         (ka2 (* ka ka)))
    (/ ka2 (+ 1.0 ka2))))

(define go
  (lambda ()
    (let* ((cl (argv))
           (pi (* 4.0 (atan 1.0)))
           (fname (list-ref cl 1))
           (x0 (string->number (list-ref cl 2)))
           (y0 (string->number (list-ref cl 3)))
           (z0 (string->number (list-ref cl 4)))
           (s (string->number (list-ref cl 5)))
           (str1 (list-ref cl 6))
           (fun (cond ((file-exists? str1)
                       (with-input-from-file str1
                          (lambda () 
                            (let ((sexp (read)))
                               (if (eq? (car sexp) 'lambda)
                                   (eval sexp)
                                   (lambda (x) 1.0))))))
                      ((string-ci=? (substring str1 0 7) "#lambda")
                       (call-with-input-string str1
                         (lambda (ip) (eval (read ip)))))
                      (else (lambda (x) 1.0))))
           (mesh (read-mesh fname x0 y0 z0 s fun))
           (l (map (lambda (x) 
                     (list x (/ (double-sum-mesh mesh (* 2.0 pi x (/ 340.0))
                                                 1.225 340.0)
                                (* 340 1.225 2.0 pi 0.02 0.02))))
                   (map exact->inexact (iota 81 0 250))))
           (outfile "out.txt"))
      (if (file-exists? outfile) (delete-file outfile) #f)
      (with-output-to-file outfile
        (lambda ()
          (for-each (lambda (e) 
                      (display (car e)) (display "         ")
                      (display (fun1 (car e))) (display "         ")
                      (display (cadr e)) (newline))
                    l))))))
(go)

(define (lexer-aux inport res)
  (let ((token (read inport)))
    (if (eof-object? token)
        (reverse res)
        (lexer-aux inport (cons token res)))))

(define (lexer filename)
  (call-with-input-file filename
     (lambda (inport) 
        (lexer-aux inport '()))))

(define (parse-success val)
  (lambda (tokens idx)
    (list val idx)))

(define (parse-fail) 
  (lambda (tokens idx)
     (list #f #f)))

(define (parse-if pred?)
  (lambda (tokens idx)
     (let ((v (list-ref tokens idx)))
       (if (pred? v)
           (list v (+ idx 1))
           (list #f #f)))))

(define (parse-seq . parsers)
  (lambda (tokens idx)
     (let seq-loop ((parsers parsers)
                    (start idx)
                    (stop idx)
                    (seq-val '()))
         (if (null? parsers)
             (list (reverse seq-val) stop)
             (let ((v1 ((car parsers) tokens stop)))
                (if (cadr v1)
                    (seq-loop (cdr parsers) start (cadr v1)
                              (cons (car v1) seq-val))
                    (list #f #f)))))))

(define (parse-choice . parsers)
  (lambda (tokens idx)
     (let choice-loop ((parsers parsers))
         (if (null? parsers)
             (list #f #f)
             (let ((v1 ((car parsers) tokens idx)))
                (if (cadr v1)
                    v1 
                    (choice-loop (cdr parsers))))))))

(define (parse-repetition parser)
  (lambda (tokens idx)
    (let rep-loop ((start idx)
                   (res '()))
       (let ((v1 (parser tokens start)))
          (if (cadr v1)
              (rep-loop (cadr v1) (cons (car v1) res))
              (list (reverse res) start))))))

(define (parse-number n)
  (parse-if (lambda (x) (and (number? x) (= x n)))))

(define (parse-symbol s)
  (parse-if (lambda (x) (and (symbol? x) (eq? x s)))))
  
(define stl-parser
  (parse-seq (parse-symbol 'solid)
             (parse-if symbol?)
             (parse-repetition
               (parse-seq (parse-symbol 'facet)
                          (parse-seq (parse-symbol 'normal)
                                     (parse-if number?)
                                     (parse-if number?)
                                     (parse-if number?))
                          (parse-symbol 'outer)
                          (parse-symbol 'loop)
                          (parse-seq (parse-symbol 'vertex)
                                     (parse-if number?)
                                     (parse-if number?)
                                     (parse-if number?))
                          (parse-seq (parse-symbol 'vertex)
                                     (parse-if number?)
                                     (parse-if number?)
                                     (parse-if number?))
                          (parse-seq (parse-symbol 'vertex)
                                     (parse-if number?)
                                     (parse-if number?)
                                     (parse-if number?))
                          (parse-symbol 'endloop)
                          (parse-symbol 'endfacet)))
               (parse-symbol 'endsolid)
               (parse-if symbol?)))

(define (transform-expr expr x0 y0 z0 s fun)
  (lambda ()
    (map (lambda (facet)
           (let ((p1 (transform-point (cdr (list-ref facet 4)) x0 y0 z0 s))
                 (p2 (transform-point (cdr (list-ref facet 5)) x0 y0 z0 s))
                 (p3 (transform-point (cdr (list-ref facet 6)) x0 y0 z0 s)))
             (let ((cent (centroid p1 p2 p3)))
               (list (cadr facet)
                     (cons 'vertex-1 p1)
                     (cons 'vertex-2 p2)
                     (cons 'vertex-3 p3)
                     (cons 'centroid cent)
                     (cons 'vnormal (fun cent))
                     (cons 'area (triangle-area p1 p2 p3))))))
     (list-ref expr 2))))

(define (transform-point p x0 y0 z0 s)
  (let* ((x (* s (- (car p) x0)))
         (y (* s (- (cadr p) y0)))
         (z (* s (- (list-ref p 2) z0))))
     (list x y z)))

(define (read-mesh meshfile x0 y0 z0 s fun)
  (let* ((res (stl-parser (lexer meshfile) 0))
         (ntokens (cadr res))
         (exp (car res)))
    (transform-expr exp x0 y0 z0 s fun)))