;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Time-stamp: <2004-06-11 12:47:27>
;;;   Touched: Thu Jan 10 12:07:20 MST 2002
;;;   Bugs-To: (enometh@net.meer)
;;;
;;;  Yi King Hexagram Encodings
;;;  (C) 2004 Madhu
;;;
(defpackage "ICHING"
  (:use "CL")
  (:export "RANDOM-HEXAGRAM"))
(in-package "ICHING")

(defstruct trigram index name pattern)
(defvar +trigrams+
  (vector
   (make-trigram :name "khien"		:index 0 :pattern #b111) ;; 7
   (make-trigram :name "kãn"		:index 1 :pattern #b001) ;; 1
   (make-trigram :name "khan"		:index 2 :pattern #b010) ;; 2
   (make-trigram :name "kãn"		:index 3 :pattern #b100) ;; 4
   (make-trigram :name "khwãn"		:index 4 :pattern #b000) ;; 0
   (make-trigram :name "sun"		:index 5 :pattern #b110) ;; 6
   (make-trigram :name "lî"		:index 6 :pattern #b101) ;; 5
   (make-trigram :name "tui"		:index 7 :pattern #b011))) ;3

(defun trigram (index) (aref +trigrams+ index))
(defun lookup-trigram (pattern)
  (trigram (aref #(4 1 2 7 3 6 5 0) pattern)))

(defstruct hexagram index name pattern)
(defvar +hexagrams+
  (vector
   nil
   (make-hexagram :name "khien"		:index 01 :pattern #b111111) ;; 63
   (make-hexagram :name "khwãn"		:index 02 :pattern #b000000) ;; 00
   (make-hexagram :name "kun"		:index 03 :pattern #b010001) ;; 17
   (make-hexagram :name "mãng"		:index 04 :pattern #b100010) ;; 34
   (make-hexagram :name "hsü"		:index 05 :pattern #b010111) ;; 23
   (make-hexagram :name "sung"		:index 06 :pattern #b111010) ;; 58
   (make-hexagram :name "sze"		:index 07 :pattern #b000010) ;; 02
   (make-hexagram :name "pî"		:index 08 :pattern #b010000) ;; 16
   (make-hexagram :name "hsiâ khû"	:index 09 :pattern #b110111) ;; 55
   (make-hexagram :name "lî"		:index 10 :pattern #b111011) ;; 59
   (make-hexagram :name "thâi"		:index 11 :pattern #b000111) ;; 07
   (make-hexagram :name "phî"		:index 12 :pattern #b111000) ;; 56
   (make-hexagram :name "thung zãn"	:index 13 :pattern #b111101) ;; 61
   (make-hexagram :name "tâ yû"		:index 14 :pattern #b101111) ;; 47
   (make-hexagram :name "khien"		:index 15 :pattern #b000100) ;; 04
   (make-hexagram :name "yü"		:index 16 :pattern #b001000) ;; 08
   (make-hexagram :name "sui"		:index 17 :pattern #b011001) ;; 25
   (make-hexagram :name "kû"		:index 18 :pattern #b100110) ;; 38
   (make-hexagram :name "lin"		:index 19 :pattern #b000011) ;; 03
   (make-hexagram :name "kwãn"		:index 20 :pattern #b110000) ;; 48
   (make-hexagram :name "shih ho"	:index 21 :pattern #b101001) ;; 41
   (make-hexagram :name "pî"		:index 22 :pattern #b100101) ;; 37
   (make-hexagram :name "po"		:index 23 :pattern #b100000) ;; 32
   (make-hexagram :name "fû"		:index 24 :pattern #b000001) ;; 01
   (make-hexagram :name "wû wang"	:index 25 :pattern #b111001) ;; 57
   (make-hexagram :name "tâ khû"	:index 26 :pattern #b100111) ;; 39
   (make-hexagram :name "î"		:index 27 :pattern #b100001) ;; 33
   (make-hexagram :name "tâ kwo"	:index 28 :pattern #b011110) ;; 30
   (make-hexagram :name "khan"		:index 29 :pattern #b010010) ;; 18
   (make-hexagram :name "lî"		:index 30 :pattern #b101101) ;; 45
   (make-hexagram :name "hsien"		:index 31 :pattern #b011100) ;; 28
   (make-hexagram :name "hãng"		:index 32 :pattern #b001110) ;; 14
   (make-hexagram :name "thun"		:index 33 :pattern #b111100) ;; 60
   (make-hexagram :name "tâ kwang"	:index 34 :pattern #b001111) ;; 15
   (make-hexagram :name "zin"		:index 35 :pattern #b101000) ;; 40
   (make-hexagram :name "ming î"	:index 36 :pattern #b000101) ;; 05
   (make-hexagram :name "kiâ zãn"	:index 37 :pattern #b110101) ;; 53
   (make-hexagram :name "khwei"		:index 38 :pattern #b101011) ;; 43
   (make-hexagram :name "kien"		:index 39 :pattern #b010100) ;; 20
   (make-hexagram :name "kieh"		:index 40 :pattern #b001010) ;; 10
   (make-hexagram :name "sun"		:index 41 :pattern #b100011) ;; 35
   (make-hexagram :name "yî"		:index 42 :pattern #b110001) ;; 49
   (make-hexagram :name "kwâi"		:index 43 :pattern #b011111) ;; 31
   (make-hexagram :name "kâu"		:index 44 :pattern #b111110) ;; 62
   (make-hexagram :name "zhui"		:index 45 :pattern #b011000) ;; 24
   (make-hexagram :name "shãng"		:index 46 :pattern #b000110) ;; 06
   (make-hexagram :name "khwãn"		:index 47 :pattern #b011010) ;; 26
   (make-hexagram :name "zing"		:index 48 :pattern #b010110) ;; 22
   (make-hexagram :name "ko"		:index 49 :pattern #b011101) ;; 29
   (make-hexagram :name "ting"		:index 50 :pattern #b101110) ;; 46
   (make-hexagram :name "kãn"		:index 51 :pattern #b001001) ;; 09
   (make-hexagram :name "kãn"		:index 52 :pattern #b100100) ;; 36
   (make-hexagram :name "kien"		:index 53 :pattern #b110100) ;; 52
   (make-hexagram :name "kwei mei"	:index 54 :pattern #b001011) ;; 11
   (make-hexagram :name "fãng"		:index 55 :pattern #b001101) ;; 13
   (make-hexagram :name "lii"		:index 56 :pattern #b101100) ;; 44
   (make-hexagram :name "sun"		:index 57 :pattern #b110110) ;; 54
   (make-hexagram :name "tui"		:index 58 :pattern #b011011) ;; 27
   (make-hexagram :name "hwân"		:index 59 :pattern #b110010) ;; 50
   (make-hexagram :name "kieh"		:index 60 :pattern #b010011) ;; 19
   (make-hexagram :name "kung fû"	:index 61 :pattern #b110011) ;; 51
   (make-hexagram :name "hsiâo kwo"	:index 62 :pattern #b001100) ;; 12
   (make-hexagram :name "kî zî"		:index 63 :pattern #b010101) ;; 21
   (make-hexagram :name "wei zî"	:index 64 :pattern #b101010)) ; 42
  "king Wãn's arrangement of the hexagrams in the Yî. Legge, James")

;;;
;;;
(defun hexagram (index) (aref +hexagrams+ index))
(defun lookup-hexagram (pattern)
  (hexagram (aref #(02 24 07 19 15 36 46 11
		    16 51 40 54 62 55 32 34
		    08 03 29 60 39 63 48 05
		    45 17 47 58 31 49 28 43
		    23 27 04 41 52 22 18 26
		    35 21 64 38 56 30 50 14
		    20 42 59 61 53 37 57 09
		    12 25 06 10 33 13 44 01) pattern)))

(defun random-hexagram (&optional repeat-p)
  (flet ((coin-toss () (if (zerop (random 2)) 'head 'tail)))
    (loop with head-score = 2 and tail-score = 3 and pattern = 0
	  for i below 6 for partial-sum = 0 collect ; 6 rows
	  (with-output-to-string (line)
	    (loop for j below 3 do	; 3 coins
		  (ecase (coin-toss)
		    (head (format line "H")
			  (cond ((and repeat-p (= j 2))	; red dot on head.
				 (ecase (coin-toss)
				   (head (format line "->H")
					 (incf partial-sum head-score))
				   (tail (format line "->T")
					 (incf partial-sum tail-score))))
				(t (incf partial-sum head-score))))
		    (tail (format line "T")
			  (incf partial-sum tail-score))))
	    (format line "~vt = ~d" (if repeat-p 7 3) partial-sum)
	    (ecase partial-sum
	      ((6 8) (format line " - -~%"))
	      ((7 9) (setf pattern (dpb 1 (byte 1 i) pattern))
	             (format line " ---~%"))))
	  into lines finally
	  (format t "~{~a~}~&" (nreverse lines))
	  (return (lookup-hexagram pattern)))))

;;;
;;;
(defmacro ensure-trigram (symbol)
  `(etypecase ,symbol
    (trigram)
    (number (setq ,symbol (trigram ,symbol)))))

(defun compose-trigrams (upper-trigram lower-trigram)
  (ensure-trigram upper-trigram)
  (ensure-trigram lower-trigram)
  (lookup-hexagram (logior (ash (trigram-pattern upper-trigram) 3)
			   (trigram-pattern lower-trigram))))

(defun pprint-trigram (trigram &optional (stream t))
  (ensure-trigram trigram)
  (format stream "(~D ~A ~3,'0b)" (trigram-index trigram)
	  (trigram-name trigram) (trigram-pattern trigram)))

(defmacro ensure-hexagram (symbol)
  `(etypecase ,symbol
    (hexagram)
    (number (setq ,symbol (hexagram ,symbol)))))

(defun lower-trigram (hexagram)
  (ensure-hexagram hexagram)
  (trigram (ldb (byte 3 0) (hexagram-pattern hexagram))))

(defun upper-trigram (hexagram)
  (ensure-hexagram hexagram)
  (trigram (ldb (byte 3 3) (hexagram-pattern hexagram))))

(defun pprint-hexagram (hexagram &optional (stream t))
  (ensure-hexagram hexagram)
  (format stream "(~D ~A ~6,'0b)" (hexagram-index hexagram)
	  (hexagram-name hexagram) (hexagram-pattern hexagram)))

;;;
;;;
(loop for upper below 8 do
      (loop for lower below 8 do
	    (assert (eq (hexagram (aref #2A((01 34 05 26 11 09 14 43)
					    (25 51 03 27 24 42 21 17)
					    (06 40 29 04 07 59 64 47)
					    (33 62 39 52 15 53 56 31)
					    (12 16 08 23 02 20 35 45)
					    (44 32 48 18 46 57 50 28)
					    (13 55 63 22 36 37 30 49)
					    (10 54 60 41 19 61 38 58))
					lower upper))
			(compose-trigrams upper lower)))))

(loop for (lower . upper) in
      '((0 . 0) (4 . 4) (1 . 2) (2 . 3) (0 . 2) (2 . 0) (2 . 4) (4 . 2)
	(0 . 5) (7 . 0) (0 . 4) (4 . 0) (6 . 0) (0 . 6) (3 . 4) (4 . 1)
	(1 . 7) (5 . 3) (7 . 4) (4 . 5) (1 . 6) (6 . 3) (4 . 3) (1 . 4)
	(1 . 0) (0 . 3) (1 . 3) (5 . 7) (2 . 2) (6 . 6) (3 . 7) (5 . 1)
	(3 . 0) (0 . 1) (4 . 6) (6 . 4) (6 . 5) (7 . 6) (3 . 2) (2 . 1)
	(7 . 3) (1 . 5) (0 . 7) (5 . 0) (4 . 7) (5 . 4) (2 . 7) (5 . 2)
	(6 . 7) (5 . 6) (1 . 1) (3 . 3) (3 . 5) (7 . 1) (6 . 1) (3 . 6)
	(5 . 5) (7 . 7) (2 . 5) (7 . 2) (7 . 5) (3 . 1) (6 . 2) (2 . 6))
      for i from 1 do
      (assert (eq (hexagram i) (compose-trigrams upper lower))))