; SPDX-FileCopyrightText: 2026 Sergei Egorov
;
; SPDX-License-Identifier: MIT

;; -*- mode: scheme; fill-column: 90; pp-inline-width: 70; pp-max-tab: 5; pp-brackets: t -*-

(import (scheme base) (scheme write))
(import (srfi 272 advanced))
;(import (srfi 272 colorize))

(define (pp-test llen input expected)
  (let ((p (open-output-string)))
    (pp (read (open-input-string input)) p pp-width llen)
    (let ((actual (get-output-string p)))
      (if (string=? actual expected)
          (begin (display "PASS: ") (display input) (newline))
          (begin
            (display "FAILED: ")
            (write input)
            (newline)
            (display "EXPECTED:")
            (newline)
            (display expected)
            (newline)
            (display "ACTUAL:")
            (newline)
            (display actual)
            (newline))))))

(define (test-cut level length input expected)
  (let*
    ((obj (let ((p (open-input-string input))) (read p)))
     (actual
      (parameterize ((pp-level level) (pp-length length))
        (let ((p (open-output-string))) (pp obj p) (get-output-string p)))))
    (if (string=? actual expected)
        (begin (display "PASS: ") (display input) (display "\n"))
        (begin
          (display "FAIL: ")
          (display input)
          (display "\n")
          (display "  Limits:   level=")
          (display level)
          (display ", length=")
          (display length)
          (display "\n")
          (display "  Expected: ")
          (write expected)
          (display "\n")
          (display "  Got:      ")
          (write actual)
          (display "\n")))))


(display "Running tests")
(newline)

(pp-test 40 "1" "1\n")
(pp-test 40 "'(a b)" "'(a b)\n")
(pp-test 40 "'(a . b)" "'(a . b)\n")
(pp-test 40 "`(,a ,@b)" "`(,a ,@b)\n")
(pp-test 80
  "(let ((x 1) (y 2) (zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz 3)) (display x) (display y))"
  "(let\n ((x 1)\n  (y 2)\n  (zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz 3))\n (display x)\n (display y))\n")

; graph cycles tests (default mode)
(pp-test 40 "#0=(a . #0#)" "#0=(a . #0#)\n")
(pp-test 40 "(1 . #0=(2 . #0#))" "(1 . #0=(2 . #0#))\n")
(pp-test 40 "#0=(1 #0# 3)" "#0=(1 #0# 3)\n")
(pp-test 40 "(#0=(1 #0# 3) #0#)" "(#0=(1 #0# 3) #0#)\n")
(pp-test 40 "(#0=(1 . #0#) #1=(1 . #1#))"
  "(#0=(1 . #0#) #1=(1 . #1#))\n")
(pp-test 40 "(#0=(a b . #0#) '#1=(a b a b . #1#))"
  "(#0=(a b . #0#) '#1=(a b a b . #1#))\n")
(pp-test 40 "(#0=(1 . 2) #1=(1 . 2) #2=(3 . 4) #0# #1# #2#)"
  "((1 . 2)\n (1 . 2)\n (3 . 4)\n (1 . 2)\n (1 . 2)\n (3 . 4))\n")
(pp-test 40 "#0=((1 . 2) (1 . 2) (3 . 4) . #0#)"
  "#0=((1 . 2) (1 . 2) (3 . 4) . #0#)\n")
(pp-test 40 "#0=#(#0#)" "#0=#(#0#)\n")
(pp-test 40 "#0=#(1 #0#)" "#0=#(1 #0#)\n")
(pp-test 40 "#0=#(1 #0# 3)" "#0=#(1 #0# 3)\n")
(pp-test 40 "(#0=#(1 #0# 3))" "(#0=#(1 #0# 3))\n")
(pp-test 40 "#0=#(#0# 2 #0#)" "#0=#(#0# 2 #0#)\n")
(pp-test 100 "#0=(a . #0#)" "#0=(a . #0#)\n")
(pp-test 100 "(#0=(a . #0#) #0#)" "(#0=(a . #0#) #0#)\n")
(pp-test 100 "#0=#(#0#)" "#0=#(#0#)\n")
(pp-test 100 "(#0=(a b) #0#)" "((a b) (a b))\n")
(pp-test 100 "#0=(#1=(a) #1# . #0#)" "#0=((a) (a) . #0#)\n")
(pp-test 100 "(#0=(a . #0#) #1=(b c) #1#)"
  "(#0=(a . #0#) (b c) (b c))\n")
(pp-test 100 "#0=(a . (#1=(b) . #0#))" "#0=(a (b) . #0#)\n")
(pp-test 100 "#0=(#(#1=(a b) #1#) . #0#)" "#0=(#((a b) (a b)) . #0#)\n")
(pp-test 100 "(#0=(a . #0#) #1=#(#1#))" "(#0=(a . #0#) #1=#(#1#))\n")
(pp-test 100 "#0=(#1=(a . #0#) #1#)" "#0=((a . #0#) (a . #0#))\n")
(pp-test 100 "(1 2 3)" "(1 2 3)\n")
(pp-test 100 "(#0=(a) #0#)" "((a) (a))\n")
(pp-test 100 "#0=(a . #0#)" "#0=(a . #0#)\n")
(pp-test 100 "(#0=(a) #1=(b . #1#) #0#)" "((a) #0=(b . #0#) (a))\n")
(pp-test 100 "#(#0=#(1) #0#)" "#(#(1) #(1))\n")
(pp-test 100 "#0=#(#0#)" "#0=#(#0#)\n")
(pp-test 100 "(#0=(1 . #0#) #1=(2 . #1#))"
  "(#0=(1 . #0#) #1=(2 . #1#))\n")
(pp-test 100 "#0=(#1=(a . #0#) . #1#)" "#0=((a . #0#) a . #0#)\n")
(pp-test 100 "(#0=(a . #0#) #0#)" "(#0=(a . #0#) #0#)\n")
(pp-test 100 "#((#0=(a) #1=(b) #0#) #1#)" "#(((a) (b) (a)) (b))\n")

; shared graph tests
(parameterize ((pp-graph #t))
  (pp-test 40 "#0=(a . #0#)" "#0=(a . #0#)\n")
  (pp-test 40 "(1 . #0=(2 . #0#))" "(1 . #0=(2 . #0#))\n")
  (pp-test 40 "#0=(1 #0# 3)" "#0=(1 #0# 3)\n")
  (pp-test 40 "(#0=(1 #0# 3) #0#)" "(#0=(1 #0# 3) #0#)\n")
  (pp-test 40 "(#0=(1 . #0#) #1=(1 . #1#))"
    "(#0=(1 . #0#) #1=(1 . #1#))\n")
  (pp-test 40 "(#0=(a b . #0#) '#1=(a b a b . #1#))"
    "(#0=(a b . #0#) '#1=(a b a b . #1#))\n")
  (pp-test 40 "(#0=(1 . 2) #1=(1 . 2) #2=(3 . 4) #0# #1# #2#)"
    "(#0=(1 . 2)\n #1=(1 . 2)\n #2=(3 . 4)\n #0#\n #1#\n #2#)\n")
  (pp-test 40 "#0=((1 . 2) (1 . 2) (3 . 4) . #0#)"
    "#0=((1 . 2) (1 . 2) (3 . 4) . #0#)\n")
  (pp-test 40 "#0=#(#0#)" "#0=#(#0#)\n")
  (pp-test 40 "#0=#(1 #0#)" "#0=#(1 #0#)\n")
  (pp-test 40 "#0=#(1 #0# 3)" "#0=#(1 #0# 3)\n")
  (pp-test 40 "(#0=#(1 #0# 3))" "(#0=#(1 #0# 3))\n")
  (pp-test 40 "#0=#(#0# 2 #0#)" "#0=#(#0# 2 #0#)\n")
  (pp-test 100 "#0=(a . #0#)" "#0=(a . #0#)\n")
  (pp-test 100 "(#0=(a . #0#) #0#)" "(#0=(a . #0#) #0#)\n")
  (pp-test 100 "#0=#(#0#)" "#0=#(#0#)\n")
  (pp-test 100 "(#0=(a b) #0#)" "(#0=(a b) #0#)\n")
  (pp-test 100 "#0=(#1=(a) #1# . #0#)" "#0=(#1=(a) #1# . #0#)\n")
  (pp-test 100 "(#0=(a . #0#) #1=(b c) #1#)"
    "(#0=(a . #0#) #1=(b c) #1#)\n")
  (pp-test 100 "#0=(a . (#1=(b) . #0#))" "#0=(a (b) . #0#)\n")
  (pp-test 100 "#0=(#(#1=(a b) #1#) . #0#)"
    "#0=(#(#1=(a b) #1#) . #0#)\n")
  (pp-test 100 "(#0=(a . #0#) #1=#(#1#))" "(#0=(a . #0#) #1=#(#1#))\n")
  (pp-test 100 "#0=(#1=(a . #0#) #1#)" "#0=(#1=(a . #0#) #1#)\n")
  (pp-test 100 "(1 2 3)" "(1 2 3)\n")
  (pp-test 100 "(#0=(a) #0#)" "(#0=(a) #0#)\n")
  (pp-test 100 "#0=(a . #0#)" "#0=(a . #0#)\n")
  (pp-test 100 "(#0=(a) #1=(b . #1#) #0#)" "(#0=(a) #1=(b . #1#) #0#)\n")
  (pp-test 100 "#(#0=#(1) #0#)" "#(#0=#(1) #0#)\n")
  (pp-test 100 "#0=#(#0#)" "#0=#(#0#)\n")
  (pp-test 100 "(#0=(1 . #0#) #1=(2 . #1#))"
    "(#0=(1 . #0#) #1=(2 . #1#))\n")
  (pp-test 100 "#0=(#1=(a . #0#) . #1#)" "#0=(#1=(a . #0#) . #1#)\n")
  (pp-test 100 "(#0=(a . #0#) #0#)" "(#0=(a . #0#) #0#)\n")
  (pp-test 100 "#((#0=(a) #1=(b) #0#) #1#)"
    "#((#0=(a) #1=(b) #0#) #1#)\n"))

; limits tests

(test-cut 0 10 "a" "a\n")
(test-cut 0 10 "(a b c)" "(...)\n")
(test-cut 0 10 "#(a b c)" "#(...)\n")
(test-cut 1 10 "(a b c)" "(a b c)\n")
(test-cut 1 10 "((a b) c)" "((...) c)\n")
(test-cut 1 10 "#((a b) c)" "#((...) c)\n")
(test-cut 1 2 "(a b c d)" "(a b ...)\n")
(test-cut 1 2 "#(a b c d)" "#(a b ...)\n")
(test-cut 1 2 "(a b . c)" "(a b . c)\n")
(test-cut 2 10 "((a b) (c d))" "((a b) (c d))\n")
(test-cut 2 10 "(((a)) b)" "(((...)) b)\n")
(test-cut 2 10 "#(#(a b) #(c #(d)))" "#(#(a b) #(c #(...)))\n")
(test-cut 2 2 "((a b c) (d e f) (g h i))" "((a b ...) (d e ...) ...)\n")
(test-cut 2 2 "#((a b c) (d e f) (g h i))"
  "#((a b ...) (d e ...) ...)\n")
(test-cut 2 3 "(a (b c d e) f g)" "(a (b c d ...) f ...)\n")
(test-cut 3 10 "(a b c d . e)" "(a b c d . e)\n")
(test-cut 3 10 "#(a (b . c) #(d e (f g)))"
  "#(a (b . c) #(d e (f g)))\n")
(test-cut 2 10 "#(a (b . c) #(d e (f g)))"
  "#(a (b . c) #(d e (...)))\n")
(test-cut 1 10 "(a . b)" "(a . b)\n")
(test-cut 1 1 "(a . b)" "(a . b)\n")
(test-cut 2 10 "((a . b) . c)" "((a . b) . c)\n")
(test-cut 2 1 "((a . b) . c)" "((a . b) . c)\n")
(test-cut 3 2 "(a b c . d)" "(a b ...)\n")
(test-cut 0 #f "(a b c)" "(...)\n")

(test-cut 1 #f "(a (b c) d)" "(a (...) d)\n")
(test-cut 2 #f "(a (b (c)) d)" "(a (b (...)) d)\n")
(test-cut 0 #f "#(1 2 3)" "#(...)\n")
(test-cut 1 #f "#(1 #(2) 3)" "#(1 #(...) 3)\n")
(test-cut 1 #f "(a b . #(c))" "(a b . #(...))\n")

(test-cut #f 0 "(a b c)" "(...)\n")
(test-cut #f 1 "(a b c)" "(a ...)\n")
(test-cut #f 3 "(a b c)" "(a b c)\n")
(test-cut #f 0 "#(1 2 3)" "#(...)\n")
(test-cut #f 2 "#(1 2 3 4)" "#(1 2 ...)\n")
(test-cut #f 1 "(a b . c)" "(a ...)\n")
(test-cut #f 2 "(a b . c)" "(a b . c)\n")
(test-cut #f 2 "(a b c . d)" "(a b ...)\n")
(test-cut #f 1 "((a b) (c d))" "((a ...) ...)\n")

(test-cut 1 1 "((a b) (c d))" "((...) ...)\n")
(test-cut 2 1 "(((a) b) c)" "(((...) ...) ...)\n")
(test-cut 0 0 "(a b c)" "(...)\n")
(test-cut 1 2 "((a b c) (d e f) (g h i))" "((...) (...) ...)\n")
(test-cut 1 2 "#(#(a b c) #(d e f) #(g h i))" "#(#(...) #(...) ...)\n")
(test-cut 1 #f "(a b . #(c d))" "(a b . #(...))\n")
(test-cut 1 #f "((a . b) . c)" "((...) . c)\n")


(parameterize ((pp-graph #t))
  (test-cut 0 #f "#0=(a . #0#)" "(...)\n")
  (test-cut 1 #f "#0=(a . #0#)" "#0=(a . #0#)\n")
  (test-cut 1 1 "#0=(a b c . #0#)" "(a ...)\n")
  (test-cut 2 2 "(#0=(a b) #0# #0#)" "(#0=(a b) #0# ...)\n")
  (test-cut 1 2 "(#0=(a b) #0# #0#)" "((...) (...) ...)\n")
  (test-cut 2 #f "#0=(#(a #0#) b)" "(#(a (...)) b)\n")
  (test-cut 1 #f "#0=(#(a #0#) b)" "(#(...) b)\n")
  (test-cut 2 1 "#0=(#(a #0#) b)" "(#(a ...) ...)\n")
  (test-cut 2 #f "(#0=(a . b) #0# . #0#)" "(#0=(a . b) #0# . #0#)\n")
  (test-cut 1 #f "(#0=(a . b) #0# . #0#)" "((...) (...) a . b)\n")
  (test-cut 3 2 "#0=((a . b) (#0# . c) d)" "#0=((a . b) (#0# . c) ...)\n")
  (test-cut 1 1 "#0=((a . b) (#0# . c) d)" "((...) ...)\n")
  (test-cut 2 #f "#0=(#(#0#) . #0#)" "#0=(#(#0#) . #0#)\n")
  (test-cut 1 #f "#0=(#(#0#) . #0#)" "#0=(#(...) . #0#)\n")
  ; this is what Chez does:
  ;(test-cut 2 2 "#0=(#1=(a b) #1# . #0#)" "#0=(#1=(a b) #1# . #0#)\n") 
  ; I believe we're entitled to this:
  (test-cut 2 2 "#0=(#1=(a b) #1# . #0#)" "(#0=(a b) #0# ...)\n")
  ; this is what Chez does:
  ;(test-cut 1 2 "#0=(#1=(a b) #1# . #0#)" "#0=((...) (...) . #0#)\n")
  ; I believe we're entitled to this:
  (test-cut 1 2 "#0=(#1=(a b) #1# . #0#)" "((...) (...) ...)\n")
  (test-cut 2 #f "#0=(a . (#1=#(b #0#) . #1#))"
    "(a #0=#(b (...)) . #0#)\n")
  (test-cut 1 #f "#0=(a . (#1=#(b #0#) . #1#))" "(a #(...) . #(...))\n")
  (test-cut 2 1 "#0=(a . (#1=#(b #0#) . #1#))" "(a ...)\n")
  (test-cut 3 3 "(#0=(a . #0#) #1=#(#1#) #2=(b c) #2#)"
    "(#0=(a . #0#) #1=#(#1#) (b c) ...)\n")
  (test-cut 0 #f "#0=(a . #0#)" "(...)\n")
  (test-cut 1 #f "#0=(a . #0#)" "#0=(a . #0#)\n")
  (test-cut 1 #f "(#0=(a b) #0#)" "((...) (...))\n")
  (test-cut #f 1 "(#0=(a b c) #0#)" "((a ...) ...)\n")
  (test-cut 0 #f "#0=#(#0#)" "#(...)\n")
  (test-cut 1 #f "#0=#(#0#)" "#(#(...))\n")
  (test-cut 1 #f "(#0=(a) #1=(#0#) #1#)" "((...) (...) (...))\n")
  (test-cut #f 1 "(a #0=(b) #0#)" "(a ...)\n")
  (test-cut #f 2 "(a #0=(b) c #0#)" "(a (b) ...)\n")
  (test-cut 2 #f "#0=(a #1=(b . #0#) . #1#)"
    "#0=(a #1=(b . #0#) . #1#)\n")
  (test-cut 1 #f "(#0=(a . b) #0#)" "((...) (...))\n")
  (test-cut #f 1 "#0=(a b . #0#)" "(a ...)\n")
  ; this is what Chez does:
  ;(test-cut #f 2 "#0=(a b . #0#)" "#0=(a b . #0#)\n")
  ; I believe we're entitled to this:
  (test-cut #f 2 "#0=(a b . #0#)" "(a b ...)\n")
  (test-cut 0 #f "(#0=() #0#)" "(...)\n")
  (test-cut 1 #f "(#0=() #0#)" "(() ())\n")
  (test-cut 1 1 "#(#0=#(a b c) #0#)" "#(#(...) ...)\n")
  (test-cut #f 1 "#(#0=#(a b c) #0#)" "#(#(a ...) ...)\n")
  (test-cut 1 2 "(#0=(a) b c . #0#)" "((...) b ...)\n")
  (test-cut 1 1 "((#0=(a) #0#) (#1=(b) #1#))" "((...) ...)\n")
  (test-cut 1 #f "#0=#(#1=(a . #0#) #1#)" "#((...) (...))\n")
  (test-cut 0 0
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))" "(...)\n")
  (test-cut 0 1
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))" "(...)\n")
  (test-cut 0 2
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))" "(...)\n")
  (test-cut 0 3
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))" "(...)\n")
  (test-cut 1 0
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))" "(...)\n")
  (test-cut 1 1
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))" "(a ...)\n")
  (test-cut 1 2
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))"
    "(a (...) ...)\n")
  (test-cut 1 3
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))"
    "(a (...) (...) ...)\n")
  (test-cut 2 0
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))" "(...)\n")
  (test-cut 2 1
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))" "(a ...)\n")
  (test-cut 2 2
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))"
    "(a (b . #(...)) ...)\n")
  (test-cut 2 3
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))"
    "(a (b . #(...)) (#(...) . d) ...)\n")
  (test-cut 3 0
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))" "(...)\n")
  (test-cut 3 1
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))" "(a ...)\n")
  (test-cut 3 2
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))"
    "(a #0=(b . #(#0# c)) ...)\n")
  (test-cut 3 3
    "#0=(a #1=(b . #2=#(#1# c)) (#2# . d) #0# . #3=(e . #3#))"
    "(a #0=(b . #1=#(#0# c)) (#1# . d) ...)\n")
  (test-cut 0 0 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)" "(...)\n")
  (test-cut 0 1 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)" "(...)\n")
  (test-cut 0 2 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)" "(...)\n")
  (test-cut 0 3 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)" "(...)\n")
  (test-cut 1 0 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)" "(...)\n")
  (test-cut 1 1 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)"
    "((...) ...)\n")
  (test-cut 1 2 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)"
    "((...) #(...) ...)\n")
  (test-cut 1 3 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)"
    "((...) #(...) (...) ...)\n")
  (test-cut 2 0 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)" "(...)\n")
  (test-cut 2 1 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)"
    "((a ...) ...)\n")
  (test-cut 2 2 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)"
    "((a (...)) #(c d ...) ...)\n")
  (test-cut 2 3 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)"
    "#0=((a (...)) #(c d (...)) (e . #0#) ...)\n")
  (test-cut 3 0 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)" "(...)\n")
  (test-cut 3 1 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)"
    "((a ...) ...)\n")
  (test-cut 3 2 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)"
    "((a (b)) #(c d ...) ...)\n")
  (test-cut 3 3 "#0=(#1=(a (b)) #2=#(c d #1#) (e . #0#) f)"
    "#0=(#1=(a (b)) #(c d #1#) (e . #0#) ...)\n"))

; for histerical reasons, read macros don't increment level
(test-cut 3 4 "'`,,@(3 . #(a b c d e f g))))"
  "'`,,@(3 . #(a b c d ...))\n")
; NB: Chez 9.5.4 hangs on all four tests below!
(test-cut 0 0 "#0='#0#" "'...\n")
(test-cut 0 1 "#0='#0#" "'...\n")
(test-cut 1 0 "#0='#0#" "#0='#0#\n")
(test-cut 1 1 "#0='#0#" "#0='#0#\n")

; skint boxes increment level
(display "Done.")
(newline)


; example

(define sexp1
  '(define
    (ast-pretty a . opt-port)
    (define
     (width x)
     (cond
      ((string? x) (+ (string-length x) 2))
      ((char? x) 3)
      ((number? x) 5)
      ((symbol? x) (string-length (symbol->string x)))
      ((boolean? x) 2)
      ((null? x) 2)
      (else 10)))
    (define
     (ast-width a)
     (cond
      ((ast-atom? a) (width (ast-atom->val a)))
      ((ast-null? a) 2)
      ((ast-pair? a)
       (if
        (ast-list? a)
        (let
         loop
         ((a a) (sum 0) (count 0))
         (if
          (ast-null? a)
          (+ sum count 1)
          (loop (ast-cdr a) (+ sum (ast-width (ast-car a))) (+ count 1))))
        (+ 1 (ast-width (ast-car a)) 3 (ast-width (ast-cdr a)) 1)))
      (else 0)))
    (define
     (ast-width-hello a)
     (display "hello!\n")
     (cond
      ((ast-atom? a) (width (ast-atom->val a)))
      ((ast-null? a) 2)
      ((ast-pair? a)
       (if
        (ast-list? a)
        (let
         loop
         ((a a) (sum 0) (count 0))
         (if
          (ast-null? a)
          (+ sum count 1)
          (loop (ast-cdr a) (+ sum (ast-width (ast-car a))) (+ count 1))))
        (+ 1 (ast-width (ast-car a)) 3 (ast-width (ast-cdr a)) 1)))
      (else
       (cond
        ((foo) => (lambda (v) (bar v 0)))
        (else (begin (newline) (if a #t #f)))))))
    (define (break? cur-col width max-col) (> (+ cur-col width) max-col))
    (define
     (print-indent n port)
     (do ((i 0 (+ i 1))) ((= i n)) (display "  " port)))
    (define
     (pretty a col indent port max-col)
     (cond
      ((ast-atom? a)
       (let
        ((w (width (ast-atom->val a))))
        (write (ast-atom->val a) port)
        (+ col w)))
      ((ast-null? a) (display "()" port) (+ col 2))
      ((ast-pair? a)
       (if
        (ast-list? a)
        (let*
         ((total-width (ast-width a))
          (remaining (- max-col col))
          (inline? (<= total-width remaining)))
         (if
          inline?
          (begin
           (display "(" port)
           (let
            loop
            ((first? #t) (rest a) (cur-col (+ col 1)))
            (if
             (ast-null? rest)
             (begin (display ")" port) (+ cur-col 1))
             (let*
              ((elem-width (ast-width (ast-car rest)))
               (new-col
                (if
                 first?
                 (pretty (ast-car rest) cur-col indent port max-col)
                 (begin
                  (display " " port)
                  (pretty (ast-car rest) (+ cur-col 1) indent port max-col)))))
              (loop #f (ast-cdr rest) new-col)))))
          (begin
           (display "(" port)
           (let
            ((new-indent (+ indent 1)))
            (let
             loop
             ((rest a) (cur-col (* new-indent 2)))
             (if
              (ast-null? rest)
              (begin (display ")" port) (+ cur-col 1))
              (let*
               ((elem (ast-car rest))
                (next-col (pretty elem cur-col new-indent port max-col)))
               (unless
                (ast-null? (ast-cdr rest))
                (newline port)
                (print-indent new-indent port))
               (loop (ast-cdr rest) (* new-indent 2)))))))))
        (begin
         (display "(" port)
         (let
          ((car-col (pretty (ast-car a) (+ col 1) indent port max-col)))
          (display " . " port)
          (let
           ((cdr-col (pretty (ast-cdr a) (+ car-col 3) indent port max-col)))
           (display ")" port)
           (+ cdr-col 1))))))))
    (let
     ((port (if (null? opt-port) (current-output-port) (car opt-port))))
     (pretty a 0 0 port 80)
     (newline port))))

(define sexp2
  '(define
    (%read port simple? ci?)
    (define-syntax
     r-error
     (syntax-rules () ((_ p msg a ...) (read-error p msg a ...))))
    (define fold-case? (or ci? (port-fold-case? port)))
    (define shared '())
    (define (make-shared-ref loc) (lambda () (unbox loc)))
    (define (shared-ref? form) (procedure? form))
    (define
     (patch-ref! form)
     (if (procedure? form) (patch-ref! (form)) form))
    (define
     (patch-shared! form)
     (cond
      ((pair? form)
       (if
        (procedure? (car form))
        (set-car! form (patch-ref! (car form)))
        (patch-shared! (car form)))
       (if
        (procedure? (cdr form))
        (set-cdr! form (patch-ref! (cdr form)))
        (patch-shared! (cdr form))))
      ((vector? form)
       (let
        loop
        ((i 0))
        (when
         (fx<? i (vector-length form))
         (let
          ((fi (vector-ref form i)))
          (if
           (procedure? fi)
           (vector-set! form i (patch-ref! fi))
           (patch-shared! fi)))
         (loop (fx+ i 1)))))
      ((box? form)
       (if
        (procedure? (unbox form))
        (set-box! form (patch-shared! (unbox form)))
        (patch-shared! (unbox form))))))
    (define (patch-shared form) (patch-shared! form) form)
    
    (define reader-token-marker #f)
    (define close-paren #f)
    (define close-bracket #f)
    (define dot #f)
    (define
     ()
     (let
      ((rtm (list 'reader-token)))
      (set! reader-token-marker rtm)
      (set! close-paren (cons rtm "right parenthesis"))
      (set! close-bracket (cons rtm "right bracket"))
      (set! dot (cons rtm "\" . \""))))
    
    (define
     (reader-token? form)
     (and (pair? form) (eq? (car form) reader-token-marker)))
    
    (define
     (char-hex-digit? c)
     (let
      ((scalar-value (char->integer c)))
      (or
       (and (>= scalar-value 48) (<= scalar-value 57))
       (and (>= scalar-value 65) (<= scalar-value 70))
       (and (>= scalar-value 97) (<= scalar-value 102)))))
    
    (define
     (char-delimiter? c)
     (or
      (char-whitespace? c)
      (char=? c #\))
      (char=? c #\()
      (char=? c #\])
      (char=? c #\[)
      (char=? c #\")
      (char=? c #\|)
      (char=? c #\;)))
    
    (define
     (sub-read-carefully p)
     (let
      ((form (sub-read p)))
      (cond
       ((eof-object? form) (r-error p "unexpected end of file"))
       ((reader-token? form) (r-error p "unexpected token:" (cdr form)))
       (else form))))
    
    (define
     (sub-read-shebang p)
     (if
      (eqv? (peek-char p) #\space)
      (string->symbol (string-trim-whitespace (read-line p)))
      (sub-read-carefully p)))
    
    (define
     (sub-read p)
     ; bumped code using %read-ahead builtin/instruction
     (let
      ((c (%read-ahead fold-case? p)))
      (cond
       ((not (char? c)) c) ; handled by %read-ahead
       ((char=? c #\() (sub-read-list c p close-paren #t))
       ((char=? c #\)) close-paren)
       ((char=? c #\[) (sub-read-list c p close-bracket #t))
       ((char=? c #\]) close-bracket)
       ((char=? c #\.) dot)
       ((char=? c #\') (list 'quote (sub-read-carefully p)))
       ((char=? c #\`) (list 'quasiquote (sub-read-carefully p)))
       ((char=? c #\n)
        (r-error p "unsupported number syntax (implementation restriction)"))
       ((char=? c #\d) (r-error p "invalid delimiter"))
       ((char=? c #\y) (r-error p "unsupported symbol syntax"))
       ((char=? c #\z) (r-error p "invalid token"))
       ((char=? c #\,)
        (let
         ((next (peek-char p)))
         (cond
          ((eof-object? next) (r-error p "end of file after ,"))
          ((char=? next #\@)
           (read-char p)
           (list 'unquote-splicing (sub-read-carefully p)))
          (else (list 'unquote (sub-read-carefully p))))))
       ((char=? c #\")
        (let
         loop
         ((l '()))
         (let
          ((c (read-char p)))
          (cond
           ((eof-object? c) (r-error p "end of file within a string"))
           ((char=? c #\\)
            (let
             ((e (sub-read-strsym-char-escape p 'string)))
             (loop (if e (cons e l) l))))
           ((char=? c #\") (list->string (reverse! l)))
           (else (loop (cons c l)))))))
       ((char=? c #\|)
        (let
         loop
         ((l '()))
         (let
          ((c (read-char p)))
          (cond
           ((eof-object? c) (r-error p "end of file within a |symbol|"))
           ((char=? c #\\)
            (let
             ((e (sub-read-strsym-char-escape p 'symbol)))
             (loop (if e (cons e l) l))))
           ((char=? c #\|) (string->symbol (list->string (reverse! l))))
           (else (loop (cons c l)))))))
       ((char=? c #\#)
        (let
         ((c (peek-char p)))
         (cond
          ((eof-object? c) (r-error p "end of file after #"))
          ((char=? c #\!)
           (read-char p)
           (let
            ((name (sub-read-shebang p)))
            (case
             name
             ((fold-case no-fold-case)
              (set! fold-case? (eq? name 'fold-case))
              (set-port-fold-case! p fold-case?)
              (sub-read p))
             (else
              (if
               (symbol? name)
               (symbol->shebang name)
               (r-error p "unexpected name after #!" name))))))
          ((or
            (char-ci=? c #\t)
            (char-ci=? c #\f)
            (char-ci=? c #\s)
            (char-ci=? c #\u))
           (let
            ((name (sub-read-carefully p)))
            (case
             name
             ((t true) #t)
             ((f false) #f)
             ((u8) (list->numvector (sub-read-numerical-list p name) 0))
             ((s8) (list->numvector (sub-read-numerical-list p name) 1))
             ((u16) (list->numvector (sub-read-numerical-list p name) 2))
             ((s16) (list->numvector (sub-read-numerical-list p name) 3))
             ((f32) (list->numvector (sub-read-numerical-list p name) 10))
             ((f64) (list->numvector (sub-read-numerical-list p name) 11))
             (else (r-error p "unexpected name after #" name)))))
          ((char=? c #\&) (read-char p) (box (sub-read-carefully p)))
          ((char=? c #\;) (read-char p) (sub-read-carefully p) (sub-read p))
          ((char=? c #\|)
           (read-char p)
           (let
            recur
            ()
            (let
             ((next (read-char p)))
             (cond
              ((eof-object? next) (r-error p "end of file in #| comment"))
              ((char=? next #\|)
               (let
                ((next (peek-char p)))
                (cond
                 ((eof-object? next) (r-error p "end of file in #| comment"))
                 ((char=? next #\#) (read-char p))
                 (else (recur)))))
              ((char=? next #\#)
               (let
                ((next (peek-char p)))
                (cond
                 ((eof-object? next) (r-error p "end of file in #| comment"))
                 ((char=? next #\|) (read-char p) (recur) (recur))
                 (else (recur)))))
              (else (recur)))))
           (sub-read p))
          ((char=? c #\() ;)
           (read-char p)
           (list->vector (sub-read-list c p close-paren #f)))
          ((char=? c #\\)
           (read-char p)
           (let
            ((c (peek-char p)))
            (cond
             ((eof-object? c) (r-error p "end of file after #\\"))
             ((char=? #\x c)
              (read-char p)
              (if (char-delimiter? (peek-char p)) c (sub-read-x-char-escape p #f)))
             ((char-alphabetic? c)
              (let
               ((name (sub-read-carefully p)))
               (if
                (= (string-length (symbol->string name)) 1)
                c
                (case
                 name
                 ((null) (integer->char 0))
                 ((space) #\space)
                 ;[(alarm) #\alarm]
                 ((backspace) #\backspace)
                 ((tab) #\tab)
                 ((newline linefeed) #\newline)
                 ((return) #\return)
                 (else (r-error p "unknown #\\ name" name))))))
             (else (read-char p) c))))
          ((char-numeric? c)
           (when
            simple?
            (r-error p "#N=/#N# notation is not allowed in this mode"))
           (let
            loop
            ((l '()))
            (let
             ((c (read-char p)))
             (cond
              ((eof-object? c) (r-error p "end of file within a #N notation"))
              ((char-numeric? c) (loop (cons c l)))
              ((char=? c #\#)
               (let*
                ((s (list->string (reverse! l))) (n (string->number s)))
                (cond
                 ((and (fixnum? n) (assq n shared)) => cdr)
                 (else (r-error p "unknown #n# reference:" s)))))
              ((char=? c #\=)
               (let*
                ((s (list->string (reverse! l))) (n (string->number s)))
                (cond
                 ((not (fixnum? n)) (r-error p "invalid #n= reference:" s))
                 ((assq n shared) (r-error p "duplicate #n= tag:" n)))
                (let
                 ((loc (box #f)))
                 (set! shared (cons (cons n (make-shared-ref loc)) shared))
                 (let
                  ((form (sub-read-carefully p)))
                  (cond
                   ((shared-ref? form) (r-error p "#n= has another label as target" s))
                   (else (set-box! loc form) form))))))
              (else (r-error p "invalid terminator for #N notation"))))))
          (else (r-error p "unknown # syntax" c)))))
       (else (r-error p "illegal character read" c)))))
    
    (define
     (sub-read-list c p close-token dot?)
     (let
      ((form (sub-read p)))
      (if
       (eq? form dot)
       (r-error p "missing car -- ( immediately followed by .") ;)
       (let
        recur
        ((form form))
        (cond
         ((eof-object? form)
          (r-error p "eof inside list -- unbalanced parentheses"))
         ((eq? form close-token) '())
         ((eq? form dot)
          (if
           dot?
           (let*
            ((last-form (sub-read-carefully p)) (another-form (sub-read p)))
            (if
             (eq? another-form close-token)
             last-form
             (r-error p "randomness after form after dot" another-form)))
           (r-error p "dot in #(...)")))
         ((reader-token? form) (r-error p "error inside list --" (cdr form)))
         (else (cons form (recur (sub-read p)))))))))
    
    (define
     (sub-read-numerical-list p ts)
     (unless
      (eq? (read-char p) #\()
      (r-error p (format "invalid ~avector syntax" ts)))
     (let
      recur
      ((form (sub-read p)))
      (cond
       ((eof-object? form) (r-error p (format "eof inside ~avector" ts)))
       ((eq? form close-paren) '())
       ((reader-token? form)
        (r-error p (format "error inside ~avector --" ts) (cdr form)))
       ((or
         (and (eq? ts 'u8) (fixnum? form) (fx<=? 0 form 255))
         (and (eq? ts 's8) (fixnum? form) (fx<=? -128 form 127))
         (and (eq? ts 'u16) (fixnum? form) (fx<=? 0 form 65535))
         (and (eq? ts 's16) (fixnum? form) (fx<=? -32768 form 32767))
         (and (eq? ts 'f32) (flonum? form))
         (and (eq? ts 'f64) (flonum? form)))
        (cons form (recur (sub-read p))))
       (else (r-error p (format "invalid ~a inside ~avector --" ts ts) form)))))
    
    (define
     (sub-read-strsym-char-escape p what)
     (let
      ((c (read-char p)))
      (if (eof-object? c) (r-error p "end of file within a" what))
      (cond
       ((or (char=? c #\\) (char=? c #\") (char=? c #\|)) c)
       ((char=? c #\a) #\alarm)
       ((char=? c #\b) #\backspace)
       ((char=? c #\t) #\tab)
       ((char=? c #\n) #\newline)
       ((char=? c #\r) #\return)
       ((char=? c #\x) (sub-read-x-char-escape p #t))
       ((and (eq? what 'string) (char-whitespace? c))
        (let
         loop
         ((gotnl (char=? c #\newline)) (nc (peek-char p)))
         (cond
          ((or (eof-object? nc) (not (char-whitespace? nc)))
           (if gotnl #f (r-error p "no newline in line ending escape")))
          ((and gotnl (char=? nc #\newline)) #f)
          (else
           (read-char p)
           (loop (or gotnl (char=? nc #\newline)) (peek-char p))))))
       (else (r-error p "invalid char escape in" what ': c)))))
    
    (define
     (sub-read-x-char-escape p in-string?)
     (define
      (rev-digits->char l)
      (if
       (null? l)
       (r-error p "\\x escape sequence is too short")
       (integer->char (string->fixnum (list->string (reverse! l)) 16))))
     (let
      loop
      ((c (peek-char p)) (l '()) (cc 0))
      (cond
       ((eof-object? c)
        (if
         in-string?
         (r-error p "end of file within a string")
         (rev-digits->char l)))
       ((and in-string? (char=? c #\;)) (read-char p) (rev-digits->char l))
       ((and (not in-string?) (char-delimiter? c)) (rev-digits->char l))
       ((not (char-hex-digit? c))
        (r-error p "unexpected char in \\x escape sequence" c))
       ((> cc 2) (r-error p "\\x escape sequence is too long"))
       (else (read-char p) (loop (peek-char p) (cons c l) (+ cc 1))))))
    
    ; body of %read
    (let
     ((form (sub-read port)))
     (if
      (not (reader-token? form))
      (if (null? shared) form (patch-shared form))
      (r-error port "unexpected token:" (cdr form))))))

(define sexp3
  '(cond
    ((equal? (token-value tok) "remove")
     (continue
      nc
      ti
      (lambda
       (tree)
       (unless
        (moore-lookup-node tree s)
        (p-error ti "notation for ~s does not exist" s))
       (moore-remove-handler tree s))))
    ((equal? (token-value tok) "additive")
     (let-parse-result
      (((hd nc ti) (parse-null nc (ti-pop ti 'lpar) rbp)))
      (define op (string->symbol s))
      (define hd (operand-token->expression tk))
      (define-values (a . b) `(,a ,@b))
      (define-values
       (ti comb)
       (if
        (eq? (token-type (ti-car ti)) 'comma)
        (values (ti-pop (ti-cdr (ti-cdr ti)) 'rpar) list)
        (values (ti-pop ti 'rpar) nary)))
      (continue
       (notation-conf-add-led nc op infix-led bp:add bp:add hd comb)
       ti
       (add-auto-handler s))))
    (else
     (p-error ti "unknown modifier for notation: ~a" (token-value tok)))))

(define sexp4
  '(define-syntax
    set*!
    (lambda
     (x)
     (letrec
      ((unwrap-exp
        (lambda
         (x)
         (let
          ((x (unwrap-syntax x)))
          (if (pair? x) (cons (car x) (unwrap-exp (cdr x))) x)))))
      (let
       ((sets (map unwrap-exp (cdr (unwrap-exp x)))))
       (let
        ((ids (map car sets))
         (vals (map cadr sets))
         (temps (map (lambda (x) (generate-identifier)) sets)))
        `(,'let
          ,(map list temps vals)
          ,@(map (lambda (id temp) `(,'set! ,id ,temp)) ids temps)
          #f)))))))

(define sexp5
  '(define
    (normalize-definition t syntax-definition?)
    (cond
     ((pair? (cdr t))
      (let
       ((_ (car t)) (head (cadr t)) (body (cddr t)))
       (cond
        ((and (identifier? head) (pair? body) (null? (cdr body)))
         `(,_ ,head unquote body))
        ((and (pair? head) (identifier? (car head)) (formals? (cdr head)))
         (let
          ((r (make-primitive-renaming-procedure)))
          (if
           syntax-definition?
           `(,_
             ,(car head)
             ,(let
               ((transformer (r (symbolic-name (car head)))))
               `((,(r 'lambda)
                  (,transformer)
                  (,(r 'lambda)
                   (,(r 'form))
                   (,(r 'apply) ,transformer ,(r 'form))))
                 (,(r 'lambda) (,(r 'dummy) unquote (cdr head)) unquote body))))
           `(,_ ,(car head) (,(r 'lambda) ,(cdr head) unquote body)))))
        (else (syntax-error "Syntax error in definition:" t)))))
     (else (syntax-error "Syntax error in definition:" t)))))


(newline)
(pp sexp1 pp-code #t pp-brackets #t pp-max-tab 5)
;(dbg #t)
;(pp sexp1 pp-code #t pp-brackets #t pp-max-tab 5)
;(pp sexp1 pp-code #f)

(newline)
(pp sexp2 pp-code #t pp-width 90 pp-brackets #t pp-max-tab 5)

(newline)
(pp sexp2 pp-code #t pp-width 90 pp-brackets #t pp-max-tab 5 pp-lines 15)

(do
  ((l
    '((0 1)
      (1 1)
      (1 2)
      (1 3)
      (1 4)
      (2 1)
      (2 2)
      (2 3)
      (3 2)
      (3 3)
      (3 4)
      (3 5))
    (cdr l)))
  ((null? l))
  (let ((level (car (car l))) (length (cadr (car l))))
    (display level)
    (display " ")
    (display length)
    (display " -- ")
    (pp '(if (member x y) (+ (car x) 3) '(foo . #(a b c d "Baz"))) pp-level level
        pp-length length)))

(pp '#u8(0 10 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)
    pp-width 20)

(pp '#u8(0 10 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)
    pp-width 20 pp-radix 2)

(pp '#u8(0 10 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)
    pp-width 20 pp-radix 8)

(pp '#u8(0 10 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)
    pp-width 20 pp-radix 10)

(pp '#u8(0 10 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)
    pp-width 20 pp-radix 16)

(newline)
(pp sexp1 pp-code #t pp-width 90 pp-brackets #t pp-max-tab 5 pp-color #t)

(newline)
(pp sexp2 pp-code #t pp-width 90 pp-brackets #t pp-max-tab 5 pp-color #t)

(newline)
(pretty-style 'let-parse-result (pretty-style 'let-values))
(pp sexp3 pp-code #t pp-width 90 pp-brackets #t pp-max-tab 5 pp-color #t)

(newline)
(pp sexp4 pp-code #t pp-width 90 pp-brackets #t pp-max-tab 5 pp-color #t)

(newline)
(pp sexp5 pp-code #t pp-width 90 pp-brackets #t pp-max-tab 5 pp-color #t)


