How Many Associative Operators?

radix 元集合上の 2 項演算子のうち結合律をみたすものの数を求める関数 nassociative を作ってみた LISP 覚えたてで使ってみたくてしょーがない俺が来ましたよ。

;;;
;;; true-table handling
;;;

(defun true-tables (radix)
  (setf *true-tables*
	(let ((tbls nil))
	  (dotimes (i (pow radix (* radix radix)) tbls)
	    (setf tbls (cons (dec->radixn radix i) tbls))))))

(defun tbl-val (tbl radix x y)
  (let ((index (+ x (* y radix))))
    (nth index tbl)))

(defun associative? (radix tbl)
  (block non-assoc
    (dotimes (z radix t)
      (dotimes (y radix)
        (dotimes (x radix)
          (if (not (eql (tbl-val tbl radix (tbl-val tbl radix x y) z)
			(tbl-val tbl radix x (tbl-val tbl radix y z))))
	      (return-from non-assoc nil)))))))

(defun nassociative (radix)
  (true-tables radix)
  (let ((n 0))
    (dolist (tbl *true-tables* n)
      (if (associative? radix tbl)
	  (setf n (+ n 1))))))

;;;
;;; debugging utilities
;;;

(defun print-true-table (radix tbl)
  (dotimes (x radix)
    (dotimes (y radix)
      (princ (car tbl))
      (setf tbl (cdr tbl))
      (princ " "))
    (princ "\n")))

(defun nth-true-table (radix n print? regen-tbls?)
  (if regen-tbls? (true-tables radix))
  (let ((tbl (nth n *true-tables*)))
    (if print?
	(print-true-table radix tbl))
    tbl))

;;;
;;; mathematical utilities
;;;

(defun dec->radixn (radix dec)
  (let ((radixn nil))
    (rshift1 radix dec radixn (* radix radix))))

(defun rshift1 (radix src dst ndigit)
  (if (zerop ndigit)
      nil
    (let ((lsb (mod src radix)))
      (append (rshift1 radix (/ src radix) dst (- ndigit 1)) (list lsb)))))

(defun pow (x y)
  (let ((res 1))
    (dotimes (i y res)
      (setf res (* res x)))))

;;;
;;; execution example
;;;

(nassociative 3)
113

とりあえず効率は気にせず分かりやすいように書いてみたので、本職のかたは添削したうえで高速化して下さい。あと何故か Common LISP じゃなくて emacs lisp です。

(nassociative 2)
8

(nassociative 3)
113

だそうです。4 以上は時間かかりすぎて求められねっす。