Racket 版本的 24 点实现

Racket 版本的 24 点实现

#lang racket

; Author: woodfox
; Date: Oct 11, 2014

; ==================== 1. Non-determinism implementation for Racket ==================
; refer to <On Lisp> by Paul Graham
(define *paths* '())
(define failsym '@)
(define (choose choices)
  (if (null? choices)
      (fail)
      (call-with-current-continuation
       (lambda (cc)
         (set! *paths*
               (cons (lambda ()
                       (cc (choose (cdr choices))))
                     *paths*))
         (car choices)))))
(define fail '())
(call-with-current-continuation
 (lambda (cc)
   (set! fail
         (lambda ()
           (if (null? *paths*)
               (cc failsym)
               (let ((p1 (car *paths*)))
                 (set! *paths* (cdr *paths*))
                 (p1)))))))
; ==================== Non-determinism implementation ENDs ==============

; ========= 2. implement permute function ==================================
; refer to: http://stackoverflow.com/questions/4180101/creating-an-n-sized-permutation-with-scheme-using-only-basic-constructs
(define (seq start end)
  (if (= start end)
      (list end)    ; if start and end are the same number, we are done
      (cons start (seq (+ start 1) end))))

(define (insert cdrList n carItem)
  (if (= 0 n)
      (cons carItem cdrList) ; if n is 0, prepend carItem to cdrList
      (cons (car cdrList)
            (insert (cdr cdrList) (- n 1) carItem))))

; (map (lambda (n)
;    (insert '(b c) n 'a))
;    '(0 1 2)) -> output of seq function given n = 2, which is length of '(b c)
; '((a b c) (b a c) (b c a)) ---> will be the output

(define (permute mylist)
  (if (null? mylist)
      '(())
      (apply append (map (lambda (plist)
                           (map (lambda (n)
                                  (insert plist n (car mylist)))
                                (seq 0 (length plist))))
                         (permute (cdr mylist))))))

;(permute '(a b c))

; ========= permute function implemenetation END =========

; ================ Calculate 24 implementation ===================
(define operators '(+ - * /))

(define-syntax-rule (mytest a b c d f1 f2 f3)
  (let ((combinations (list `(,f3 (,f1 ,a ,b) (,f2 ,c ,d))
                            `(,f3 (,f2 (,f1 ,a ,b) ,c) ,d)
                            `(,f3 (,f2 ,a (,f1 ,b ,c)) ,d)
                            `(,f3 ,a (,f2 (,f1 ,b ,c) ,d))
                            `(,f3 ,a (,f2 ,b (,f1 ,c ,d))))))
    (let ((expr (choose combinations)))
      (with-handlers ([exn:fail:contract:divide-by-zero?
                       (lambda (exn) (fail))])
        (if (= 24 (eval expr))
            (displayln expr)
            (fail))))))

(define (calc24 nums)
  (let ((nums2 (choose (permute nums))))
    (let ((a (car nums2))
          (b (cadr nums2))
          (c (caddr nums2))
          (d (cadddr nums2))
          (f1 (choose operators))
          (f2 (choose operators))
          (f3 (choose operators)))
      (mytest a b c d f1 f2 f3))))

真正跟 24点逻辑相关的是最后一小段， “Calculate 24 implementation” 注释开始后的代码，代码不多。

前面都是准备工作，一小段代码实现了不确定性计算的自动回溯功能；

另一小段代码是实现了全排列的辅助函数。

测试：

欢迎使用 DrRacket, 版本 5.3.3 [3m].
语言: racket; memory limit: 128 MB.
> (calc24 '(4 5 6 7))
(* 4 (+ (- 5 6) 7))
> (fail)
(* 4 (- 5 (- 6 7)))
> (fail)
(* (+ (- 5 6) 7) 4)
> (calc24 '(3 3 8 8))
(/ 8 (- 3 (/ 8 3)))
>

每次调用可以输出一个解。如果想要更多的解，执行一次 (fail) 函数就可以了，每执行一次会自动回溯，找到下一个解，直到无解为止。

在用 '(3 3 8 8) 这个例子尝试的时候，顺带发现了前面 Haskell 版本写的一个 bug, 即：

想当然的以为全排列后每次取到的4个数应该不一样，因此把有重复数字的情况都排除掉了，求不到解。

这个 Racket 版本在做的时候，顺带修正了这个 bug.

回头晚一点把 Haskell 的也 fix 一下。

完毕。