PasteRack.org
Paste # 56511
2022-12-18 16:54:32

Fork as a new paste.

Paste viewed 1498 times.


Embed:

Crypartithmetic solver macro

  1. #lang racket
  2.  
  3. (require (for-syntax racket/list))
  4.  
  5. (define (k-perms xs k)
  6.   (define (helper xs m)
  7.     (define (perms-starting x)
  8.       (map (lambda (ps) (cons x ps))
  9.            (helper (remove x xs) m)))
  10.     (if (< (length xs) m)
  11.         '(())
  12.         (apply append (map (lambda (x) (perms-starting x)) xs))))
  13.   (helper xs (add1 (- (length xs) k))))
  14.  
  15. (begin-for-syntax
  16.    (define (is-var? x)
  17.     (and (symbol? x)
  18.          (andmap char-upper-case?
  19.                  (string->list (symbol->string x)))))
  20.  
  21.    (define (make-nexpr var)
  22.      (define letters
  23.        (reverse
  24.         (map string->symbol (map string (string->list (symbol->string var))))))
  25.      (define (loop xs weight exprlist)
  26.        (if (null? xs)
  27.            (cons '+ (apply append exprlist))
  28.            (loop (cdr xs)
  29.                  (* weight 10)
  30.                  (cons `((* ,(car xs) ,weight)) exprlist))))
  31.      (loop letters 1 '()))
  32.  
  33.     (define (get-unique-letters cexpr)
  34.     (map string->symbol
  35.          (remove-duplicates
  36.           (map string
  37.                (string->list
  38.                 (apply string-append
  39.                        (map symbol->string
  40.                             (extract-var-list cexpr))))))))
  41.  
  42.     (define (extract-var-list cexpr)
  43.       (cond [(null? cexpr) '()]
  44.             [(is-var? cexpr) (list cexpr)]
  45.             [(pair? cexpr) (append (extract-var-list (car cexpr))
  46.                                    (extract-var-list (cdr cexpr)))]
  47.             [else '()]))
  48.  
  49.   (define (make-cryptexpr-check-fn cexpr)
  50.     (define (helper cexpr)
  51.       (cond
  52.         [(null? cexpr) '()]
  53.         [(is-var? cexpr) (make-nexpr cexpr)]
  54.         [(pair? cexpr) (cons (helper (car cexpr))
  55.                              (helper (cdr cexpr)))]
  56.         [else cexpr]))
  57.     (let ([all-vars (get-unique-letters cexpr)])
  58.       `(lambda ,all-vars ,(helper cexpr))))
  59.  
  60.   (define (make-puzzle-solver cexpr)
  61.     (let* ([check (make-cryptexpr-check-fn cexpr)]
  62.            [letters (get-unique-letters cexpr)]
  63.            [match-criteria (cons 'list (get-unique-letters cexpr))])
  64.       `(let ([check ,check])
  65.          (for-each
  66.           (lambda (sol)
  67.             (match sol
  68.               [,match-criteria
  69.              (display ',letters)
  70.              (newline)
  71.              (display sol)
  72.              (newline)
  73.              (newline)]))
  74.           (filter (lambda (p) (apply check p))
  75.                   (k-perms (range 0 10) ,(length letters)))))))
  76.  
  77.    (define (solve-puzzle-transformer stx)
  78.     (datum->syntax stx (make-puzzle-solver (second (syntax->datum stx))))))
  79.  
  81. (define-syntax solve-puzzle solve-puzzle-transformer)
  82.  
  83. (solve-puzzle (= (+ ODD ODD) EVEN))
  84.  

=>

(O D E V N)

(6 5 1 3 0)

(O D E V N)

(8 5 1 7 0)