<commit_before>;;;
;;; Alignment-based sequence fusing
;;;

(define-library (rad fuse)

   (export fuse)

   (import (owl base))

   (begin

      (define (car> a b) (> (car a) (car b)))

      ;; todo: move suffix mutations to a separate library or to (rad generic)
      (define (match-prefix lst p)
         (cond
            ((null? p) #true)
            ((null? lst) #false)
            ((eq? (car lst) (car p))
               (match-prefix (cdr lst) (cdr p)))
            (else #false)))

      (define (occurrences lst pat)
         (let loop ((lst lst) (found null) (pos 0))
            (cond
               ((null? lst) found)
               ((match-prefix lst pat)
                  (loop (cdr lst) (cons pos found) (+ pos 1)))
               (else
                  (loop (cdr lst) found (+ pos 1))))))

      (define (add-suffix ff ls)
         (if (null? ls)
            ff
            (lets ((x ls ls))
               (put ff x
                  (cons ls (get ff x null))))))

      (define (note-substring occurrences rbytes others)
         (let ((score (* (- occurrences 1) (* (- (length rbytes) 1) 2))))
            (if (< score 1)
               others
               (cons (cons score rbytes) others))))

      ;; → ((score reverse-bytes ..) ...)
      (define (radix-walk lsts path n found)
         (cond
            ((null? lsts) found)
            ((null? (cdr lsts)) found)
            ((eq? n 0) found)
            (else
               (ff-fold
                  (λ (found char tails)
                     (radix-walk tails (cons char path) (- n 1)
                        (note-substring (length tails) (cons char path) found)))
                  found
                  (fold add-suffix #false lsts)))))

      ;; list of list suffixes
      (define (suffixen lst)
         (if (null? lst)
            null
            (cons lst (suffixen (cdr lst)))))

      ;; ((i . x) (j . z) ...) n → z
      (define (priority-pick l n)
         (let ((m (caar l)))
            (if (<= n m)
               (cdar l)
               (priority-pick (cdr l) (- n m)))))


      ;; todo: make surf max jump size a command line flag
      (define (frequent-substring rs lst)
         (lets
            ((rs max-depth (rand-range rs 4 20)) ; <- 32 gives a max 100ms search
             (subs (radix-walk (suffixen lst) null max-depth null))
             (subs (sort car> subs))
             (rs n (rand rs (fold + 0 (map car subs)))))
            (if (null? subs) ;; <- blank → null
               (values rs null)
               (values rs (reverse (priority-pick subs n))))))

      ;; poss quaranteed to have >= 2 elems
      (define (choose-jump rs poss len)
         (lets
            ((rs poss (random-permutation rs poss))
             (from (car poss))
             (to (cadr poss)))
            (if (= (+ from len) (- to 1)) ;; wouldn't change the data
               (values to from)
               (values from to))))

      (define (fuse rs al bl)
         (values rs 
            (append al bl)))

      ;(define (sed-seq-surf rs ll meta) ;; jump between two shared suffixes in the block
      ;   (lets
      ;      ((lst (vector->list (car ll)))
      ;       (rs root (frequent-substring rs lst))
      ;       (poss (occurrences lst root)))
      ;      ;; a jump list of one element is constructed for blocks with just one byte
      ;      ;(show "SURF: jumping " (list 'from from 'to to 'using root))
      ;      (if (> (length poss) 1) ;; extremely likely for non-random data
      ;         (lets
      ;            ((from to (choose-jump rs poss (length root)))
      ;             (block (car ll))
      ;             (get (λ (p) (refb block p)))
      ;             (rs d (rand-delta-up rs))
      ;             (pre (list->byte-vector (map get (iota 0 1 from))))
      ;             (post (list->byte-vector (map get (iota to 1 (sizeb block))))))
      ;            (values sed-seq-surf rs 
      ;               (ilist pre post (cdr ll))
      ;               (inc meta 'seq-surf)
      ;               d))
      ;         (values sed-seq-surf rs ll meta -1))))

))<commit_msg>rewrote alignment-based jumper to allow more flexible two-block mutations and swapped ss to use it<commit_after>;;;
;;; Alignment-based sequence fusing
;;;

(define-library (rad fuse)

   (export fuse)

   (import 
      (owl base))

   (begin

      (define (jump lst from to)
         (if (eq? lst from)
            to
            (cons (car lst)
               (jump (cdr lst) from to))))

      (define (suffixes lst)  
         (if (null? lst)
            null
            (cons lst (suffixes (cdr lst)))))

      (define (char-suffixes sufs)
         (fold
            (λ (subs suf)
               (if (null? suf)
                  subs
                  (put subs (car suf)
                     (cons (cdr suf) (get subs (car suf) null)))))
            #false sufs))

      ;; node = ((suffix ...) . (suffix ...))
      (define (split node tl)
         (lets
            ((sas (char-suffixes (car node)))
             (sbs (char-suffixes (cdr node))))
            (ff-fold
               (λ (tl char sufs) ;; all suffixes in a after prefix+char
                  (let ((bs (getf sbs char)))
                     (if bs ;; there were some also in b
                        (cons (cons sufs bs) tl)
                        tl))) ;; nothing shared
               tl sas)))

      (define (try-choose rs nodes)
         (lets/cc3 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)))
                  (if a 
                     (values rs a b)
                     (loop rs (>> prob 1))))))) ;; always terminates immediately if 1

      (define (fuse rs al bl)
         (lets ((rs a b (find-pair rs al bl)))
            (values rs (jump al a b))))

      ;(lets ((rs l (fuse (seed->rands (time-ms)) '(1 2 3 a b c 4) '(5 6 a b c 7 8 9))))
      ;   (print l))
))
{'fraction_non_alphanumeric': 0.12864240633812274, 'fraction_numerical': 0.00523700819121794, 'mean_word_length': 1.2413481793560035, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 14, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 1, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7076913', 'n_tokens_mistral': 2297, 'n_tokens_neox': 2095, 'n_words': 809}