(define (rp m v) (begin (write (list m v)) (newline) v))
(define (p x) (cons (/ (log x)(log 2))(number->string x 2)))
(define (NSP) (let ((s (cons 0 0)))
  (cons (lambda (x) (cons x s))
     (lambda (x) (if (eq? (cdr x) s) (car x))))))
; NSP (New Sealer Pair) above is a naive creator of sealer unsealer pairs.
(define (desc k) (let ((sp (NSP))
  (& bitwise-and)(bor bitwise-ior)(^ bitwise-xor)
  (<< arithmetic-shift))
; size like first-bit-set in SRFI 60
  (letrec ((log (lambda (n) (if (zero? n) -1
  (if (zero? (& n #xffff)) (+ 16 (log (<< n -16)))
  (if (zero? (& n #xff)) (+ 8 (log (<< n -8)))
  (let ((n15 (& n #xf)))
    (if (zero? n15) (+ 4 (log (<< n -4)))
  (& #xf (<< #x102010301020104 (- (* 4 n15) 64))))))))))
; len is like integer-length in SRFI 60
  (len (lambda (n) (if (> n #xffff) (+ 16 (len (<< n -16)))
  (if (> n #xff) (+ 8 (len (<< n -8)))
  (if (> n #xf) (+ 4 (len (<< n -4)))
  ;(vector-ref #(0 1 2 2 3 3 3 3 4 4 4 4 4 4 4 4) n)
  (& #xf (<< #x122333344444444 (- (* 4 n) 60)))))))))
  (let ((us (cdr sp))(sl (car sp))
    (range (lambda (x) (let ((m (- x 1))) (cons (& x m) (bor x m))))))
  (let* ((iwithin (lambda (a b) (or (zero? a)
    (let ((ra (range a))(rb (range b)))
      (and (<= (car rb) (car ra)) (<= (cdr ra) (cdr rb)))))))
  (isize (lambda (x) (+ (^ x (- x 1)) 1)))
  (size (lambda (X) (isize (us X))))
  (within (lambda (A B) (iwithin (us A) (us B))))
  (locate (lambda (A B) (let ((a (us A))(b (us B)))
    (if (iwithin a b) (^ (^ a b) (<< (isize b) -1)) 0))))
  (sub (lambda (A b) (let* ((a (us A))(t (isize a)))
    (sl (if (<= b t) (bor (^ a (<< t -1)) b) 0))))))
  (cons (sl (<< 1 (- k 1))) (let ((ls `(
    (within . ,within) (locate . ,locate) (size . ,size) (sub . ,sub)
    (zer . ,(sl 0))
    (zer? . ,(lambda (x) (zero? (us x))))
    (eq . ,(lambda (A B) (= (us A)(us B)))))))
  (lambda (sy) (cdr (assq sy ls))))))))))

; Hardware abstractions above
(let* ((a (desc 38))(top (car a))) (apply
 (lambda (in sub loc size zer zer? eq) (let ((r18 (sub top #x18))
 (t1 (lambda (a b) (or (not (in a b)) (eq (sub b (loc a b)) a)))))
   (list (in zer r18) (in r18 top)
     (t1 r18 r18) (t1 r18 top) (t1 (sub top #x60) r18)
   (p (loc r18 top))(p (size top))(sub top 0)(loc top r18))))
(map (cdr a) (list 'within 'sub 'locate 'size 'zer 'zer? 'eq))))