PasteRack.org
Paste # 31082
2017-05-22 02:04:13

Fork as a new paste.

Paste viewed 86 times.


Embed:

  1. #lang racket
  2.  
  3. (require racket/set)
  4. (require racket/list)
  5.  
  6. (define (insertions start end b ans)
  7.   (if (empty? end) (cons start ans)
  8.       (insertions (append start (list (first end))) (rest end) b
  9.                   (if (empty? (set-intersect (last (first end)) (last b))) ans
  10.                       (cons (append start (cons b (rest end))) ans)))))
  11.  
  12. (define (perms a b)
  13.   (if (empty? b) (list (map first a))
  14.       (append-map (lambda (x) (perms x (rest b)))
  15.                   (insertions empty a (first b) empty))))
  16.  
  17. ; (make-port "motel" 2 "hotel" 3) -> "motel"
  18. (define (make-port l1 p1 l2 p2)
  19.   (string-append
  20.    (substring l1 0 (+ p1 1))
  21.    (substring l2 (+ p2 1))))
  22.  
  23. ;(all-ports "motor" "hotel" 0 0) -> (list "motel" "mototel" "motel")
  24. (define (all-ports l1 l2 p1 p2)
  25.   (if (= p1 (string-length l1))
  26.       (all-ports l1 l2 0 (+ p2 1))
  27.       (if (= p2 (string-length l2))
  28.           empty
  29.           (if (equal? (substring l1 p1 (+ p1 1)) (substring l2 p2 (+ p2 1)))
  30.               (cons (make-port l2 p2 l1 p2)
  31.                     (cons (make-port l1 p1 l2 p2)
  32.                           (all-ports l1 l2 (+ p1 1) p2)))
  33.               (all-ports l1 l2 (+ p1 1) p2)))))
  34.  
  35. (define (lcs str sub i j)
  36.   (if (= j (+ (string-length sub) 1))
  37.       (lcs str sub (+ i 1) (+ i 1))
  38.       (if (= i (string-length sub))
  39.           0
  40.           (if (string-contains? (substring sub i j) str)
  41.               (max (- j i) (lcs str sub i (+ j 1)))
  42.               (lcs str sub i (+ j 1))))))
  43.  
  44. (define (agm a b)
  45.   (if (< (abs (- a b)) 1e-9)
  46.       a
  47.       (agm (/ (+ a b) 2) (sqrt (* a b)))))
  48.  
  49. (define (score ab a b)
  50.   (- (agm (lcs ab a 0 1) (lcs ab b 0 1))
  51.      (abs (- (* 2 (string-length ab))
  52.              (string-length a)
  53.              (string-length b)))))
  54.  
  55. (define (best ports a b)
  56.   (if (empty? ports)
  57.       (list "" 0)
  58.       (let ([cur (best (rest ports) a b)])
  59.         (let ([val (score (first ports) a b)])
  60.           (if (> val (first (rest cur)))
  61.               (list (first ports) val)
  62.               cur)))))
  63.  
  64. (define (portmanteau s1 s2)
  65.   (let ([ports (all-ports s1 s2 0 0)])
  66.     (if (empty? ports)
  67.         (string-append s1 (string-append " x " s2))
  68.         (first (best ports s1 s2)))))
  69.  
  70. ;(all-ports "hotel" "motor" 0 0)
  71. ;(score "motel" "hotel" "motor")
  72. ;(score "mototel" "hotel" "motor")
  73. ;(best (list "motel" "mototel") "motor" "hotel")
  74.  
  75. (portmanteau "motor" "hotel")

=>

""