ver36.scm

#! /usr/bin/env gosh
; klg, May 2019 !#

(define (filter pred lst) ; or just (use srfi-1)
  (let loop ((lst lst))
    (cond
      ((null? lst) lst)
      ((pred (car lst))
       (cons (car lst) (loop (cdr lst))))
      (else (loop (cdr lst))))))

(define string->base36-list
  (let ((tab (make-vector 128 #f)))
    (do ((i 0 (+ i 1))) ((= i 10))
      (vector-set! tab (+ i 48) i))
    (do ((i 0 (+ i 1))) ((= i 27))
      (vector-set! tab (+ i 65) (+ i 10))
      (vector-set! tab (+ i 97) (+ i 10)))
    (lambda (str)
      (filter (lambda (x) x)
              (map (lambda (ch)
                     (let ((n (char->integer ch)))
                       (if (< n (vector-length tab))
                           (vector-ref tab n) #f)))
                   (string->list str))))))

(define base36->char
  (let ((tab (list->vector (string->list
                             "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"))))
    (lambda (chr) (vector-ref tab chr))))

(define sigma18
  (let ((tab '#(29 0 32 11 35 20 7 27 2 4 19 28 30 1 5 12 3 9 16 
                22 6 33 8 24 26 21 14 10 34 31 15 25 17 13 23 18)))
    (lambda (x n)
      (do ((n (modulo n 600) (- n 1))
           (x x (vector-ref tab x)))
        ((= n 0) x)))))

(define (fold-verhoeff36 lst)
  (let loop ((lst lst)
             (i (- (length lst) 1))
             (k #t) (x 0))
    (if (null? lst)
        (if k x (+ x 18))
        (let ((y (sigma18 (car lst) i)))
          (loop (cdr lst) (- i 1)
                (eq? k (< y 18))
                (modulo
                  ((if (< y 18) + -) y x)
                  18))))))

(define (ver36-verify str)
  (eqv? 0 (fold-verhoeff36 (string->base36-list str))))

(define (ver36-append str)
  (define (dih18-inverse x)
    (if (< 0 x 18) (- 18 x) x))
  (let ((c (dih18-inverse
             (fold-verhoeff36 (map (lambda (x) (sigma18 x 1))
                                   (string->base36-list str))))))
    (string-append str (string (base36->char c)))))


(define (main args)
  (let ((err 0))
    (if (and
          (> (length args) 1)
          (string=? (cadr args) "-a"))
        (for-each
          (lambda (str)
            (display (ver36-append str))
            (newline))
          (cddr args))
        (for-each
          (lambda (str)
            (display str)
            (if (ver36-verify str)
                (display ": OK\n")
                (begin
                  (display ": INCORRECT\n")
                  (set! err (+ 1 err)))))
          (cdr args)))
    err))