Skip to content

GitLab

Commit 2a60310a authored by Niels Möller's avatar Niels Möller
Browse files

*** empty log message *** 

Rev: src/lsh_keygen.c:1.3
Rev: src/make_char_classes:1.1
parent 7ff9d349
Hide whitespace changes
Inline Side-by-side
src/lsh_keygen.c
View file @ 2a60310a
/* lsh_keygen.c
*
* Generic key-generation program. Writes a spki-packages private key
* Generic key-generation program. Writes a spki-packaged private key
* on stdout. You would usually pipe this to some other program to
* extract the public key, encrypt the private key, and save the
* results in two separate files.
......
src/make_char_classes 0 → 100755
View file @ 2a60310a
#! /usr/local/bin/scsh \
-e main -s
!#
;; Reads an alist of character classes and their contents,
;; computes a partition of disjunct sets, associate a bit with each
;; partition set, and finally writes a C file containing
;; a partition table index by character, and masks corresponding to
;; the input classes.
(define (my-error s . args)
(error (apply format #f s args)))
(define (debug s . args)
; (apply format (error-output-port) s args))
#f)
(define (werror s . args)
(apply format (error-output-port) s args))
(define (filter p l)
(cond ((null? l) l)
((p (car l))
(cons (car l) (filter p (cdr l))))
(else (filter p (cdr l)))))
(define (reduce op start l)
(if (null? l)
start
(reduce op (op start (car l)) (cdr l))))
(define (subvector v start end)
(let ((n (make-vector (- end start))))
(let loop ((i start))
(when (< i end)
(vector-set! n (- i start) (vector-ref v i))
(loop (+ i 1))))
n))
(define (vector-split v n)
(let ((parts (make-vector n))
(length (quotient (+ (vector-length v) n -1) n)))
(let loop ((i 0) (start 0))
(cond ((= i (- n 1))
(vector-set! parts i (subvector v start (vector-length v))))
(else
(vector-set! parts i (subvector v start (+ start length)))
(loop (+ i 1) (+ start length)))))
parts))
(define (implode separator list)
(cond ((null? list) "")
((null? (cdr list)) (car list))
(else
(string-append (car list) separator (implode separator (cdr list))))))
;;
(define (input->char-set o)
(define (->ascii x)
(if (integer? x) x
(char->ascii x)))
(cond ((string? o)
(string->char-set o))
((list? o)
(reduce char-set-union (chars->char-set
(map ascii->char (filter integer? o)))
(map (lambda (pair)
(ascii-range->char-set (->ascii (car pair))
(+ 1 (->ascii (cdr pair)))))
(filter pair? o))))
(else (my-error "Bad char set specification ~s" o))))
;; Depends on charsets implemented as strings
(define char-set=? string=?)
(define char-set-empty?
(let ((empty (chars->char-set '())))
(lambda (o) (char-set=? o empty))))
(define char-set-assoc assoc)
;; We use an acyclic graph, where the input char-sets are used as
;; roots, and two intersecting nodes will branch into three childen,
;; one of which is shared. The children of each node are disjunct.
;;
;; ABC BCD
;; / \ / \
;; A BC D
(define (make-tree set)
;; Fields are set, leafness, left and right child (if any) and indexnumber.
(vector set #t #f #f #f))
(define (tree/set tree)
(vector-ref tree 0))
(define (tree/leaf? tree)
(vector-ref tree 1))
(define (tree/left tree)
(vector-ref tree 2))
(define (tree/right tree)
(vector-ref tree 3))
(define (tree/split! tree left right)
(cond ((tree/leaf? tree)
(vector-set! tree 1 #f)
(vector-set! tree 2 left)
(vector-set! tree 3 right))
(else (my-error "Attempt to split non-leaf"))))
(define (tree/index tree)
(vector-ref tree 4))
(define (tree/index! tree n)
(vector-set! tree 4 n))
(define (tree-describe tree)
(if (tree/leaf? tree)
(list 'leaf
(tree/index tree)
(char-set-members (tree/set tree)))
(list 'node
(char-set-members (tree/set tree))
(tree-describe (tree/left tree))
(tree-describe (tree/right tree)) )))
(define (make-tree-cache initial)
(let ((cache (map (lambda (tree) (cons (tree/set tree) tree))
initial)))
(lambda (set)
(debug "cache: ~s\n" (map (lambda (pair) (char-set-members (car pair)))
cache))
(cond ((char-set-assoc set cache)
=> cdr)
(else
(let ((new (make-tree set)))
(debug "Adding set ~s\n" (char-set-members set))
(set! cache (cons (cons set new) cache))
new))))))
(define (for-children f tree)
(f (tree/left tree))
(f (tree/right tree)))
;; Iterate over all leafs
(define (for-leafs f tree)
(if (tree/leaf? tree)
(f tree)
(for-children (lambda (c) (for-leafs f c)) tree)))
(define (map-leafs f tree)
(if (tree/leaf? tree)
(list (f tree))
(append (map-leafs f (tree/left tree))
(map-leafs f (tree/right tree)))))
;; Destructivly intersect the leafs of two trees
(define (tree-intersect! cache t1 t2)
(if (eq? t1 t2)
t1
(let* ((s1 (tree/set t1))
(s2 (tree/set t2))
(intersection (char-set-intersection s1 s2)))
(if (not (char-set-empty? intersection))
(if (tree/leaf? t1)
(if (tree/leaf? t2)
(let ((diff1 (char-set-difference s1 s2))
(diff2 (char-set-difference s2 s1)))
(define (split-subset! super sub diff)
(tree/split! super sub (cache diff)))
(if (char-set-empty? diff1)
(if (char-set-empty? diff2)
(my-error "Two copies of ~s ~s"
(tree-describe t1)
(tree-describe t2))
; t1 is a subset of t2, so we need only split t2
(split-subset! t2 t1 diff2))
(if (char-set-empty? diff2)
; t2 is a subset of t1, so split t1
(split-subset! t1 t2 diff1)
; Both differences ar non-empty, so split both
(let ((common (cache intersection)))
(tree/split! t1 common (cache diff1))
(tree/split! t2 common (cache diff2))))))
; t1 is a leaf, but not t2. Recurse.
(for-children (lambda (c)
(tree-intersect! cache t1 c))
t2))
; t1 is a non-leaf
(for-children (lambda (c)
(tree-intersect! cache t2 c))
t1))))))
(define-syntax when
(syntax-rules () ((when test . consequences) (if test (begin . consequences)))))
(define (partition! sets)
(let ((cache (make-tree-cache sets)))
(let loop ((left sets))
(let ((head (car left))
(tail (cdr left)))
(when (not (null? tail))
(for-each (lambda (tree) (tree-intersect! cache head tree))
tail)
(loop tail))))))
(define (index-leafs! roots)
(let ((index 1)
(leafs '()))
(for-each (lambda (tree)
(for-leafs (lambda (leaf)
(when (not (tree/index leaf))
(tree/index! leaf index)
(set! index (+ 1 index))
(set! leafs (cons leaf leafs))))
tree))
roots)
leafs))
(define (build-char-table leafs)
(let ((table (make-vector #x100 0)))
(for-each (lambda (leaf)
(let ((flag (tree/index leaf)))
(for-each (lambda (c)
(vector-set! table (char->ascii c) flag))
(char-set-members (tree/set leaf)))))
leafs)
table))
(define (build-mask root)
(map-leafs tree/index root))
(define (prepare-input l)
(map (lambda (pair)
(cons (car pair) (make-tree (input->char-set (cdr pair)))))
l))
(define test-input
'((alpha . ( (#\a . #\z) (#\A . #\Z) ))
(digits . ( (#\0 . #\9)))
(base64 . ( (#\a . #\z) (#\A . #\Z) (#\0 . #\9) #\+ #\/ #\=))
(hex . ( (#\0 . #\9) (#\a . #\f) (#\A . #\F) ))))
(define (test1)
(let* ((input (prepare-input test-input))
(roots (map cdr input)))
(partition! roots)
(let ((leafs (index-leafs! roots)))
(werror "~s disjunct classes found." (length leafs))
(build-char-table leafs))))
#!
(map (lambda (pair)
(cons (car pair) (tree-describe (cdr pair))))
input)))
!#
(define (bit->mask bit)
(format #f "1L<<~s" bit))
(define (make-char-classes input)
(let* ((classes (prepare-input input))
(roots (map cdr classes)))
(partition! roots)
(let ((leafs (index-leafs! roots)))
(werror "~s disjunct classes found.\n" (length leafs))
(format #t "int char_classes[] = {\n ~a\n};\n\n"
(implode ",\n "
(map (lambda (row)
(implode ", " (map bit->mask
(vector->list row))))
(vector->list (vector-split (build-char-table leafs)
32))))))
(for-each (lambda (class)
(format #t "#define CHAR_~a (~a)\n"
(car class)
(implode " | " (map bit->mask (build-mask (cdr class))))))
classes)
(format #t "#define CHAR_other 1\n")))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment