Skip to content

Commit

Permalink
manual sync with code at haltp
Browse files Browse the repository at this point in the history
  • Loading branch information
@aoh
aoh committed Dec 6, 2014
1 parent 28502ee commit 2240a91
Show file tree
Hide file tree
Showing 20 changed files with 1,434 additions and 174 deletions.
1 change: 1 addition & 0 deletions .gitignore
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,3 +2,4 @@
radamsa.c
tmp
bin/radamsa
owl-lisp
19 changes: 19 additions & 0 deletions LICENCE
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,19 @@
Copyright (c) 2013 Aki Helin

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
17 changes: 14 additions & 3 deletions Makefile
View file
Original file line number Diff line number Diff line change
@@ -1,8 +1,8 @@
DESTDIR=
PREFIX=/usr
BINDIR=/bin
CFLAGS=-Wall -O3
OFLAGS=-O1
CFLAGS=-Wall -O2
OFLAGS=-O2
OL=owl-lisp/bin/ol

W32GCC=i586-mingw32msvc-gcc # sudo apt-get install mingw32 @ debian squeeze
Expand All @@ -13,6 +13,14 @@ bin/radamsa: radamsa.c
mkdir -p bin
$(CC) $(CFLAGS) -o bin/radamsa radamsa.c

fasl: radamsa.fasl
echo "#!/usr/bin/owl-vm" > fasl
cat radamsa.fasl >> fasl
chmod +x fasl

radamsa.fasl: rad/*.scm
$(OL) -o radamsa.fasl rad/main.scm

bin/radamsa.exe: radamsa.c
which $(W32GCC)
$(W32GCC) $(CFLAGS) -o bin/radamsa.exe radamsa.c -lwsock32
Expand All @@ -39,10 +47,13 @@ clean:
get-owl:
# fetching and building owl to build radamsa
# this may take a few minutes on first build
-git clone http://haltp.org/git/owl-lisp.git
-git clone https://github.com/aoh/owl-lisp.git
-cd owl-lisp && git pull
cd owl-lisp && make

todo:
grep -n "^ *;;* *todo:" rad/* | sed -e 's/: *;;* *todo:/ →/'

# standalone build for shipping
standalone:
-rm radamsa.c # likely old version
Expand Down
98 changes: 36 additions & 62 deletions rad/fuse.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,10 @@

(begin

(define search-fuel 100000)

(define search-stop-ip 8)

(define (jump lst from to)
(if (eq? lst from)
to
Expand All @@ -31,8 +35,21 @@
(cons (cdr suf) (get subs (car suf) null)))))
empty sufs))

(define (any-position-pair rs nodes)
(lets
((rs node (rand-elem rs nodes))
(froms tos node)
(rs from (rand-elem rs froms))
(rs to (rand-elem rs tos)))
(values rs from to)))


;; .------------------------> source list suffixes after a shared prefix
;; | .--------> target -||-
;; | v
;; v
;; node = ((suffix ...) . (suffix ...))
(define (split node tl)
(define (split tl node)
(lets
((sas (char-suffixes (car node)))
(sbs (char-suffixes (cdr node))))
Expand All @@ -41,72 +58,29 @@
(let ((bs (getf sbs char)))
(if bs ;; there were some also in b
(cons (cons sufs bs) tl)
tl))) ;; nothing shared
tl))) ;; nothing shared after char
tl sas)))

(define (try-choose rs nodes)
(lets/cc ret
((rs nodes (random-permutation rs nodes)))
(fold
(λ (rs node)
(lets
((rs as (random-permutation rs (car node)))
(rs bs (random-permutation rs (cdr node))))
(let loop ((as as) (bs bs))
(cond
((null? as) rs)
((null? bs) rs)
((equal? (car as) (car bs)) rs) ;; don't jump to the same place
(else
;; return via cont
(ret rs (car as) (car bs)))))))
rs nodes)
;; if nothig found
(values rs #false #false)))

;; walk in parallel all shared strings of given length
; rs nodes prob → rs' a|#f b|#f
(define (try-pair rs nodes prob)
(if (null? nodes)
(values rs #false #false)
(lets ((rs n (rand rs prob)))
(if (eq? n 0)
(try-choose rs nodes) ;; choose a pair out of current nodes
(lets
((subs (foldr split null nodes))
(rs a b (try-pair rs subs prob)))
(if a
(values rs a b)
(try-choose rs nodes))))))) ;; nothing shared below, try here

(define (find-pair rs a b)
(let ((nodes (list (cons (suffixes a) (suffixes b)))))
(let loop ((rs rs) (prob 8))
(lets ((rs a b (try-pair rs nodes prob)))
(cond
(a (values rs a b))
((= prob 1) ;; escape
(values rs (caaar nodes) (cadar nodes)))
(else
(loop rs (>> prob 1)))))))) ;; always terminates immediately if 1
(define (find-jump-points rs a b)
(lets
((al (suffixes a))
(bl (suffixes b))
(nodes (list (cons al bl))))
(let loop ((rs rs) (nodes nodes) (fuel search-fuel))
(if (< search-fuel 0)
(any-position-pair rs nodes)
(lets ((rs x (rand rs search-stop-ip)))
(if (eq? x 0)
(any-position-pair rs nodes)
(let ((nodesp (fold split null nodes)))
(if (null? nodesp)
(any-position-pair rs nodes)
(loop rs nodesp (- fuel (length nodesp)))))))))))

(define (fuse rs al bl)
(cond
((null? al) (values rs bl))
((null? bl) (values rs al))
(else
(lets ((rs a b (find-pair rs al bl)))
(values rs (jump al a b))))))

#|(let loop ((rs (seed->rands (time-ms))))
(lets
((rs al (rand rs 10))
(rs bl (rand rs 10))
(rs a (random-numbers rs 4 al))
(rs b (random-numbers rs 4 bl))
(_ (print (list a '+ b)))
(rs x (fuse rs a b))
(_ (print (list a '+ b '= x))))
(loop rs)))|#

))
(lets ((rs a b (find-jump-points rs al bl)))
(values rs (jump al a b))))))))
60 changes: 35 additions & 25 deletions rad/generators.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,36 +19,50 @@

(define (rand-block-size rs)
(lets ((rs n (rand rs max-block-size)))
(values rs (max n 4))))
(values rs (max n min-block-size))))

;; bvec|F bvec → bvec
(define (merge head tail)
(if head
(list->vector (vec-foldr cons (vec-foldr cons null tail) head))
tail))

(define (finish rs len)
(lets ((rs n (rand rs (+ len 1)))) ;; 1/(n+1) probability of possibly adding extra data
(if (eq? n 0)
(lets
((rs bits (rand-range rs 1 16))
(rs len (rand rs (<< 1 bits)))
(rs bytes (random-numbers rs 256 len)))
(list (list->byte-vector bytes)))
null)))

;; store length so that extra data can be generated in case of no or very
;; little sample data, which would cause one or very few possible outputs

(define (stream-port rs port)
(lets ((rs first (rand-block-size rs)))
(let loop ((rs rs) (last #false) (wanted first)) ;; 0 = block ready (if any)
(let loop ((rs rs) (last #false) (wanted first) (len 0)) ;; 0 = block ready (if any)
(let ((block (get-block port wanted)))
(cond
((eof? block) ;; end of stream
;(if (not (eq? port stdin)) (close-port port))
(if (not (eq? port stdin)) (fclose port))
(if last (list last) null))
((not block) ;; read error
;(if (not (eq? port stdin)) (close-port port))
(if last
(cons last (finish rs (+ len (sizeb last))))
(finish rs len)))
((not block) ;; read error, could be treated as error
(if (not (eq? port stdin)) (fclose port))
(if last (list last) null))
((eq? (sizeb block) wanted)
;; a block of required (deterministic) size is ready
(lets
((block (merge last block))
(rs next (rand-block-size rs)))
(pair block (loop rs #false next))))
(pair block (loop rs #false next (+ len (sizeb block))))))
(else
(loop rs (merge last block)
(- wanted (sizeb block)))))))))
(- wanted (sizeb block))
len)))))))

;; rs port → rs' (bvec ...), closes port unless stdin
(define (port->stream rs port)
Expand Down Expand Up @@ -95,23 +109,19 @@
((paths (list->vector paths))
(n (vec-len paths)))
(define (gen rs)
;; todo: approximates failing after trying a random permutation of paths
(let loop ((rs rs) (tries 0)) ;; no longer loops, can remove
(if (= tries 100)
(values rs #false "Cannot read")
(lets
((rs n (rand rs n))
(path (vec-ref paths n))
(port (open-input-file path)))
(if port
(lets ((rs ll (port->stream rs port)))
(values rs ll
(list->ff (list '(generator . file) (cons 'source path)))))
(begin
(if (dir->list path)
(print*-to stderr (list "Error: failed to open '" path "'. Please use -r if you want to include samples from directories."))
(print*-to stderr (list "Error: failed to open '" path "'")))
(halt exit-read-error)))))))
(lets
((rs n (rand rs n))
(path (vec-ref paths n))
(port (open-input-file path)))
(if port
(lets ((rs ll (port->stream rs port)))
(values rs ll
(list->ff (list '(generator . file) (cons 'source path)))))
(begin
(if (dir->list path)
(print*-to stderr (list "Error: failed to open '" path "'. Please use -r if you want to include samples from directories."))
(print*-to stderr (list "Error: failed to open '" path "'")))
(halt exit-read-error)))))
gen))

(define (string->generator-priorities str)
Expand Down
59 changes: 51 additions & 8 deletions rad/generic.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,14 +2,6 @@
;;; Simple Generic Linear Mutations
;;;

;; todo: stateful generic mutations
;; mutator rs state arg ... → rs' state'
;; automatic fold0-style behavior for state-dependent ones for first use
;; state preservation strategies:
;; - reservoir sampling -style
;; - last state
;; - always grow or probabilistic A + B?

(define-library (rad generic)

(import
Expand All @@ -25,6 +17,9 @@
list-swap ;; etc
list-perm ;
list-fuse

st-list-ins ;; rs st l → rs' st' l'
st-list-replace ;; rs st l → rs' st' l'
)

(begin
Expand Down Expand Up @@ -137,6 +132,54 @@
;; connect prefix of al somewhere to bl, and make sure that (list-fuse l l) != l
(define list-fuse fuse)

;; mutations which keep some old elements for mutations in (n-elems elem-1 elem2 ...)
(define stored-elems 10)
(define update-prob (<< stored-elems 1))

(define (step-state rs st l len)
(if (< (car st) stored-elems)
;; add elements until there are enough stored elements
(lets ((rs p (rand rs len)))
(step-state rs
(ilist (+ 1 (car st))
(lref l p)
(cdr st))
l len))
(lets
((rs up (rand rs update-prob)))
(if (< up stored-elems)
;; update a stored element
(lets
((rs ep (rand rs len))
(new (lref l ep))
(st (edit st (+ 1 up) (λ (tl) (cons (lref l ep) (cdr tl)))))) ; +1 for len
(values rs st))
(values rs st)))))

(define (pick-state rs st)
(lets ((rs p (rand rs (car st))))
(values rs (lref (cdr st) p))))

(define (st-list-ins rs st l)
(lets
((n (length l))
(rs st (step-state rs st l n))
(rs x (pick-state rs st))
(rs p (rand rs n))
(lp (edit l p (λ (tl) (cons x tl)))))
(values rs st lp)))

(define (st-list-replace rs st l)
(lets
((n (length l))
(rs st (step-state rs st l n))
(rs x (pick-state rs st))
(rs p (rand rs n))
(lp (edit l p (λ (tl) (cons x (cdr tl))))))
(values rs st lp)))

;; st-list-swap st-list-ins
;;

;;;
;;; Testing
Expand Down
Loading

0 comments on commit 2240a91

Please sign in to comment.