zr-tex8r/isqrt.scm

## isqrt.scm
;
; isqrt.scm
;
(load "./sanierer")

; Input expressions to string-lot can contain
; the following special forms:
;   (lambda (<var>) <body>)
;     NB. The arity must be one.
;   (^ (<var>) <expr>) ; short form of the above
;   (let ((<var> <val>)) <body>)
;     NB. There must be exactly one variable bound.
;   (let1 <var> <val> <body) ; short form of the above
;   (let* ((<var> <val>)...) <body>)
;     NB. Multiple variables are allowed.

(define isqrt-prog (quote
(let1 zero (^(s) (^(z) z))
(let1 inc (^(n) (^(s) (^(z) (s ((n s) z)))))
(let1 two (^(s) (^(z) (s (s z))))
(let1 stars (^(n) ((n (^(x) (cons "*" x))) '()))
(let1 leq (^(m) (^(n)
  (let1 ra (^(f) (^(g) (g f)))
    (((m ra) (^(h) (^(t) (^(f) t))))
     ((n ra) (^(h) (^(t) (^(f) f))))))))
(let1 isqrt (^(n)
  (let1 iter (^(self) (^(k)
     (let1 sk (inc k)
       (((((leq (two sk)) n)
            (^(z) ((self self) sk)))
            (^(z) k))
          zero))))
    ((iter iter) zero)))
(stars (isqrt ((inc two) two)))
))))))))

; (string-lot <S-expr>) gives the string that forms
; a LISP-on-TeX expression equivalent to the S-expr.
; (display (string-lot isqrt-prog))
(print-lot isqrt-prog) ; same as above
;; EOF

## sanierer.scm
;
; sanierer.scm
;

(define (scm->intm expr)
  (define (head-eq? x sym)
    (and (pair? x) (eq? (car x) sym)))
  (define (let->lambda cls)
    (if (= (length (cadr cls)) 1)
        (let* ((bind (car (cadr cls)))
               (var (car bind))
               (val (cadr bind))
               (expr (caddr cls)))
          `((lambda (,var) ,expr) ,val))
        (error "let must be used with a single binding")))
  (define (let*->let1 cls)
    (if (null? (cadr cls))
        (caddr cls)
        (let* ((binds (cadr cls))
               (var (car (car binds)))
               (val (cadr (car binds)))
               (binds1 (cdr binds))
               (expr (caddr cls)))
          `(let1 ,var ,val
             (let* ,binds1 ,expr)))))
  (define (let1->lambda cls)
    (let* ((var (cadr cls))
           (val (caddr cls))
           (expr (cadddr cls)))
      `((lambda (,var) ,expr) ,val)))
  (define (simp-lambda cls)
    (let* ((var (car (cadr cls)))
           (expr (scm->intm (caddr cls))))
      `(lambda ,var ,expr)))
  (cond ((head-eq? expr 'let)
          (scm->intm (let->lambda expr)))
        ((head-eq? expr 'let1)
          (scm->intm (let1->lambda expr)))
        ((head-eq? expr 'let*)
          (scm->intm (let*->let1 expr)))
        ((head-eq? expr 'lambda)
          (simp-lambda expr))
        ((head-eq? expr '^)
          (simp-lambda expr))
        ((pair? expr)
          (cons (scm->intm (car expr)) (scm->intm (cdr expr))))
        (else expr)))
(define (intm->lot expr)
  (cond ((pair? expr)
          (string-append "("
              (intm->lot (car expr)) "."
              (intm->lot (cdr expr)) ")"))
        ((null? expr) "()")
        ((symbol? expr)
          (string-append "\\" (symbol->string expr)))
        ((number? expr) (number->string expr))
        ((string? expr) expr)
        (else "?")))
(define (string-lot expr)
  (intm->lot (scm->intm expr)))

(define (print-lot expr)
  (display (string-lot expr)) (newline))
(define (print-evaled expr)
  (display (eval expr (interaction-environment)))
  (newline))
;; EOF

## test-isqrt.tex
\documentclass{article}
\usepackage{lisp}
\begin{document}
%% The code \expA is equivalent to:
% (define zero 0)
% (define (inc n) (+ n 1))
% (define two 2)
% (define (stars n)
%   (do ((k 0 (+ k 1)) (x '() (cons "*" x))) ((= k n) x)))
% (define leq <=)
% (define (isqrt n)
%   (let loop ((k zero))
%     (let ((sk (inc k)))
%       (if (leq (expt sk two) n) (loop sk)
%           k))))
% (stars (isqrt (expt two (inc two))))
\lispread\expA{%
((\lambda.(\zero.(((\lambda.(\inc.(((\lambda.(\two.(((\lambda.(\stars.((%
(\lambda.(\leq.(((\lambda.(\isqrt.((\stars.((\isqrt.(((\inc.(\two.())).(%
\two.())).())).())).()))).((\lambda.(\n.(((\lambda.(\iter.(((\iter.(%
\iter.())).(\zero.())).()))).((\lambda.(\self.((\lambda.(\k.(((\lambda.(%
\sk.((((((\leq.((\two.(\sk.())).())).(\n.())).((\lambda.(\z.(((\self.(%
\self.())).(\sk.())).()))).())).((\lambda.(\z.(\k.()))).())).(\zero.()))%
.()))).((\inc.(\k.())).())).()))).()))).())).()))).())).()))).((\lambda.%
(\m.((\lambda.(\n.(((\lambda.(\ra.((((\m.(\ra.())).((\lambda.(\h.((%
\lambda.(\t.((\lambda.(\f.(\t.()))).()))).()))).())).(((\n.(\ra.())).((%
\lambda.(\h.((\lambda.(\t.((\lambda.(\f.(\f.()))).()))).()))).())).())).%
()))).((\lambda.(\f.((\lambda.(\g.((\g.(\f.())).()))).()))).())).()))).(%
)))).())).()))).((\lambda.(\n.(((\n.((\lambda.(\x.((\cons.(*.(\x.()))).(%
)))).())).((\quote.(().())).())).()))).())).()))).((\lambda.(\s.((%
\lambda.(\z.((\s.((\s.(\z.())).())).()))).()))).())).()))).((\lambda.(\n%
.((\lambda.(\s.((\lambda.(\z.((\s.(((\n.(\s.())).(\z.())).())).()))).())%
)).()))).())).()))).((\lambda.(\s.((\lambda.(\z.(\z.()))).()))).()))%
}
\batchmode % non-stop running without terminal output
\lispeval\expA\valA
\errorstopmode % back to normal error handling
\lispprint\valA
\end{document}
	;
	; isqrt.scm
	;
	(load "./sanierer")

	; Input expressions to string-lot can contain
	; the following special forms:
	; (lambda (<var>) <body>)
	; NB. The arity must be one.
	; (^ (<var>) <expr>) ; short form of the above
	; (let ((<var> <val>)) <body>)
	; NB. There must be exactly one variable bound.
	; (let1 <var> <val> <body) ; short form of the above
	; (let* ((<var> <val>)...) <body>)
	; NB. Multiple variables are allowed.

	(define isqrt-prog (quote
	(let1 zero (^(s) (^(z) z))
	(let1 inc (^(n) (^(s) (^(z) (s ((n s) z)))))
	(let1 two (^(s) (^(z) (s (s z))))
	(let1 stars (^(n) ((n (^(x) (cons "*" x))) '()))
	(let1 leq (^(m) (^(n)
	(let1 ra (^(f) (^(g) (g f)))
	(((m ra) (^(h) (^(t) (^(f) t))))
	((n ra) (^(h) (^(t) (^(f) f))))))))
	(let1 isqrt (^(n)
	(let1 iter (^(self) (^(k)
	(let1 sk (inc k)
	(((((leq (two sk)) n)
	(^(z) ((self self) sk)))
	(^(z) k))
	zero))))
	((iter iter) zero)))
	(stars (isqrt ((inc two) two)))
	))))))))

	; (string-lot <S-expr>) gives the string that forms
	; a LISP-on-TeX expression equivalent to the S-expr.
	; (display (string-lot isqrt-prog))
	(print-lot isqrt-prog) ; same as above
	;; EOF
	;
	; sanierer.scm
	;

	(define (scm->intm expr)
	(define (head-eq? x sym)
	(and (pair? x) (eq? (car x) sym)))
	(define (let->lambda cls)
	(if (= (length (cadr cls)) 1)
	(let* ((bind (car (cadr cls)))
	(var (car bind))
	(val (cadr bind))
	(expr (caddr cls)))
	`((lambda (,var) ,expr) ,val))
	(error "let must be used with a single binding")))
	(define (let*->let1 cls)
	(if (null? (cadr cls))
	(caddr cls)
	(let* ((binds (cadr cls))
	(var (car (car binds)))
	(val (cadr (car binds)))
	(binds1 (cdr binds))
	(expr (caddr cls)))
	`(let1 ,var ,val
	(let* ,binds1 ,expr)))))
	(define (let1->lambda cls)
	(let* ((var (cadr cls))
	(val (caddr cls))
	(expr (cadddr cls)))
	`((lambda (,var) ,expr) ,val)))
	(define (simp-lambda cls)
	(let* ((var (car (cadr cls)))
	(expr (scm->intm (caddr cls))))
	`(lambda ,var ,expr)))
	(cond ((head-eq? expr 'let)
	(scm->intm (let->lambda expr)))
	((head-eq? expr 'let1)
	(scm->intm (let1->lambda expr)))
	((head-eq? expr 'let*)
	(scm->intm (let*->let1 expr)))
	((head-eq? expr 'lambda)
	(simp-lambda expr))
	((head-eq? expr '^)
	(simp-lambda expr))
	((pair? expr)
	(cons (scm->intm (car expr)) (scm->intm (cdr expr))))
	(else expr)))
	(define (intm->lot expr)
	(cond ((pair? expr)
	(string-append "("
	(intm->lot (car expr)) "."
	(intm->lot (cdr expr)) ")"))
	((null? expr) "()")
	((symbol? expr)
	(string-append "\\" (symbol->string expr)))
	((number? expr) (number->string expr))
	((string? expr) expr)
	(else "?")))
	(define (string-lot expr)
	(intm->lot (scm->intm expr)))

	(define (print-lot expr)
	(display (string-lot expr)) (newline))
	(define (print-evaled expr)
	(display (eval expr (interaction-environment)))
	(newline))
	;; EOF
	\documentclass{article}
	\usepackage{lisp}
	\begin{document}
	%% The code \expA is equivalent to:
	% (define zero 0)
	% (define (inc n) (+ n 1))
	% (define two 2)
	% (define (stars n)
	% (do ((k 0 (+ k 1)) (x '() (cons "*" x))) ((= k n) x)))
	% (define leq <=)
	% (define (isqrt n)
	% (let loop ((k zero))
	% (let ((sk (inc k)))
	% (if (leq (expt sk two) n) (loop sk)
	% k))))
	% (stars (isqrt (expt two (inc two))))
	\lispread\expA{%
	((\lambda.(\zero.(((\lambda.(\inc.(((\lambda.(\two.(((\lambda.(\stars.((%
	(\lambda.(\leq.(((\lambda.(\isqrt.((\stars.((\isqrt.(((\inc.(\two.())).(%
	\two.())).())).())).()))).((\lambda.(\n.(((\lambda.(\iter.(((\iter.(%
	\iter.())).(\zero.())).()))).((\lambda.(\self.((\lambda.(\k.(((\lambda.(%
	\sk.((((((\leq.((\two.(\sk.())).())).(\n.())).((\lambda.(\z.(((\self.(%
	\self.())).(\sk.())).()))).())).((\lambda.(\z.(\k.()))).())).(\zero.()))%
	.()))).((\inc.(\k.())).())).()))).()))).())).()))).())).()))).((\lambda.%
	(\m.((\lambda.(\n.(((\lambda.(\ra.((((\m.(\ra.())).((\lambda.(\h.((%
	\lambda.(\t.((\lambda.(\f.(\t.()))).()))).()))).())).(((\n.(\ra.())).((%
	\lambda.(\h.((\lambda.(\t.((\lambda.(\f.(\f.()))).()))).()))).())).())).%
	()))).((\lambda.(\f.((\lambda.(\g.((\g.(\f.())).()))).()))).())).()))).(%
	)))).())).()))).((\lambda.(\n.(((\n.((\lambda.(\x.((\cons.(*.(\x.()))).(%
	)))).())).((\quote.(().())).())).()))).())).()))).((\lambda.(\s.((%
	\lambda.(\z.((\s.((\s.(\z.())).())).()))).()))).())).()))).((\lambda.(\n%
	.((\lambda.(\s.((\lambda.(\z.((\s.(((\n.(\s.())).(\z.())).())).()))).())%
	)).()))).())).()))).((\lambda.(\s.((\lambda.(\z.(\z.()))).()))).()))%
	}
	\batchmode % non-stop running without terminal output
	\lispeval\expA\valA
	\errorstopmode % back to normal error handling
	\lispprint\valA
	\end{document}