;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*- ;;; ;;; Time-stamp: <2009-05-24 15:34:27 IST> ;;; Touched: Mon Nov 03 16:56:34 2008 +0530 ;;; Bugs-To: enometh@meer.net ;;; Status: Experimental. Do not redistribute ;;; Copyright (C) 2008 Madhu. All Rights Reserved. ;;; ;;; VEDIC ASTROLOGY ;;; ;;; References: 3rd reader KRISHNAMURTHI PADHDHATI, K.S.Krishnamurthi, ;;; Mahabala Publishers, 12, Brahmin Street, Saidapet Madras-15, Feb 1976 (defpackage "KP-ASTROLOG-1-1" (:nicknames "AST") (:use "CL") (:export)) (in-package "KP-ASTROLOG-1-1") (defvar +planets+ '(Ketu ; ketu, South Node Venus ; "sukra, velli Sun ; surya Moon ; candra Mars ; kuja, ma.ngal, "sevvai Rahu ; raahu, North Node Jupiter ; guru, b.rhaspati, vyaazhan Saturn ; "sani Mercury ; budha )) (defvar +signs+ '(Aries ; me.sa Taurus ; v.r.sabha Gemini ; mithuna Cancer ; karkata Leo ; simha Virgo ; kanyaa Libra ; tulaa Scorpio ; v.r"scika Sagittarius ; dhanus Capricorn ; makara Aquarius ; kumbha Pisces ; miina )) (defvar +stars+ '(Ashwini ; a"svinii, Arietus Star 3 Bharani ; bhara.nii, Arietisa Mus-3 Krithikka ; k.rttikaa, Alcyoni-6, Karthikai Rohini ; rohi.nii, Aldeboran-5 Mrigasira ; m.riga"sira, Orionis-3, Mrigasirisha Arudhra ; aardraa, Orionis-1, Thuiruvadhirai Punarvasu ; punarvasu, Gemini Pollux-5, Punarpushyam Pushyam ; pu.sya, Cancri-3 Aslesha ; aa"sle.saa, Hydrae 6 Makam ; maghaa, Leonis Regulae 5 Poorvaphalguni ; puurvaphalgunii, Pubba, Pooram Uthraphalguni ; uttaraphalgunii, Leonis-4, Uthhram Hastham ; hasta, Corvi-5 Chithra ; citraa, Virginis Spica-1", Swathi ; svaatii, Bootis Arcturus-1 Visakam ; vi"saakhaa, Librae-3 Anuradha ; anuraadhaa, Scorpionmis-3, Anusham Jyeshta ; jye.s.thaa, Antares-3,Kettai Moolam ; muula, Scorpionis-6 poorvashada ; puurvaa.saa.dhaa, Sagittari-4, Pooradam Uthrashada ; uttaraa.saa.dhaa, Sagittari-4, Utthiradam Sravana ; "srava.na, Aquilate-3 Dhanishta ; "sravi.s.thaa, Delphini-4, Avittam Shathabhisha ; "satabhi.sak, Aquari-100, Sathayam Poorvapathrapada ; puurvapro.s.thapada, [bhaadra], Pegasi-4, Poorattathi Uthrapathrapada ; uttarapro.s.thapada, [bhaadra], Andramedae-4, Utthiratthathi Revathi ; revati, Piscium-3 )) (eval-when (load) (mapcar 'export (list +planets+ +signs+ +stars+))) ;;; ---------------------------------------------------------------------- ;;; ;;; (defun remprops (list &rest indicators) "Internal. If no INDICATORS are specified null remove all properties from all symbols in LIST. Otherwise remove specified properties." (mapcar (lambda (var) (if indicators (mapcar (lambda (indicator) (remprop var indicator)) indicators) (setf (symbol-plist var) nil))) list)) (defun relist (list head-item) "HEAD-ITEM must be a member of LIST. Return a list whose first element is HEAD-ITEM and contains all items of LIST in the same order as LIST. Shares structure with LIST." (let ((tail (member head-item list))) (assert tail nil "HEAD-ITEM ~S not a member of ~S." head-item list) (append tail (ldiff list tail)))) ;;; ---------------------------------------------------------------------- ;;; ;;; SET SYMBOL PROPERTIES ;;; ;; clear all symbol properties (mapcar 'remprops (list +stars+ +planets+ +signs+)) ;; assign serial numbers (mapcar (lambda (vars) (let ((n 0)) (mapcar (lambda (var) (setf (get var :number) (incf n))) vars))) (list +stars+ +planets+ +signs+)) ;; vimshottari ratios --- denominator 120. (defvar +vimshottari-ratios+ '(7 20 6 10 7 18 16 19 17)) (mapcar (lambda (planet ratio) (setf (get planet :vimshottari-ratio) ratio)) +planets+ +vimshottari-ratios+) ;; set rulers (defvar +rasi-rulers+ '(Mars Venus Mercury Moon Sun Mercury Venus Mars Jupiter Saturn Saturn Jupiter)) (mapcar (lambda (sign ruler) (setf (get sign :ruler) ruler) (pushnew sign (get ruler :rules-signs))) +signs+ +rasi-rulers+) (mapcar (lambda (star ruler) (setf (get star :ruler) ruler) (pushnew star (get ruler :rules-stars))) +stars+ (let ((c (copy-list +planets+))) (setf (cdr (last c)) c))) ;;; ---------------------------------------------------------------------- ;;; ;;; (defun compute-zodiac-interval-for-sign (sign) "Internal. Divides the zodiac equally amongst 12 signs. Return \(SIGN BEG END) ratios denoting degrees between 0-360." (let ((sign-number (get sign :number))) (list sign (* 30 (1- sign-number)) (* 30 sign-number)))) (mapcar (lambda (sign) (destructuring-bind (beg end) (cdr (compute-zodiac-interval-for-sign sign)) (setf (get sign :zodiac-interval) (list beg end)))) +signs+) (defun compute-zodiac-interval-for-star (star) "Internal. Divides the zodiac equally amongst 27 stars. Return \(STAR BEG END) ratios denoting degrees between 0-360." (let ((star-number (get star :number))) (list star (* 40/3 (1- star-number)) (* 40/3 star-number)))) (mapcar (lambda (star) (destructuring-bind (beg end) (cdr (compute-zodiac-interval-for-star star)) (setf (get star :zodiac-interval) (list beg end)))) +stars+) (defun compute-zodiac-zones (star) "Internal. Divides each sign into 3 zones among 3 stars. Return a iist of \(STAR SIGN BEG END) ratios denoting degrees between 0 and 30 in SIGN." (destructuring-bind (star-zodiac-interval-begin star-zodiac-interval-end) (cdr (compute-zodiac-interval-for-star star)) (multiple-value-bind (beg-sign-number beg-rem) (truncate star-zodiac-interval-begin 30) (multiple-value-bind (end-sign-number end-rem) (truncate star-zodiac-interval-end 30) (if (= end-sign-number beg-sign-number) (list (list star (nth beg-sign-number +signs+) beg-rem end-rem)) (list* (list star (nth beg-sign-number +signs+) beg-rem 30) (unless (= end-rem 0) (list (list star (nth end-sign-number +signs+) 0 end-rem))))))))) (mapcar (lambda (star) (loop for (star sign beg end) in (compute-zodiac-zones star) do (pushnew (list star :interval (list sign beg end) :zodiac-interval (let ((sign-zodiac-start (car (get sign :zodiac-interval)))) (list (+ sign-zodiac-start beg) (+ sign-zodiac-start end)))) (get sign :zones) :test #'equalp) (pushnew sign (get star :signs)))) +stars+) (defun compute-zodiac-subs (star) "Internal. Divides each star into 9 subdivisions among 9 planets according to the KP system in proportion to the ratios of vimshottari dasas for planets. Return a list of \(PLANET STAR SIGN BEG END) ratios denoting degrees between 0 and 30 in SIGN." (let* ((ruler (get star :ruler)) (planets (relist +planets+ ruler)) (divisions (mapcar (lambda (planet) (* (/ (get planet :vimshottari-ratio) 120) (/ 360 27))) planets)) (checksum 0)) (loop for (star sign beg end) in (compute-zodiac-zones star) for running-total = beg finally (assert (= checksum (/ 360 27))) nconc (loop while (and planets divisions (< running-total end)) collect (let ((planet (car planets)) (degrees (car divisions))) (cond ((<= degrees (- end running-total)) (pop planets) (pop divisions) (incf checksum degrees) (list planet star sign running-total (incf running-total degrees))) (t (let ((rem (- end running-total))) (decf (car divisions) rem) (assert (= (+ running-total rem) end)) ;terminate (incf checksum rem) (list planet star sign running-total (incf running-total rem)))))))))) (mapcar (lambda (star) (loop for (planet star sign beg end) in (compute-zodiac-subs star) do (pushnew (list planet :interval (list sign beg end) :zodiac-interval (let ((sign-zodiac-start (car (get sign :zodiac-interval)))) (list (+ sign-zodiac-start beg) (+ sign-zodiac-start end)))) (get star :subs) :test #'equalp))) +stars+) ;;; ---------------------------------------------------------------------- ;;; ;;; ;;; (export '(convert-to-longitude convert-longitude-to-zodiac-longitude convert-longitude-to-degrees-minutes-seconds)) (defun convert-ratio-to-degrees-minutes-seconds (number) "Return (DEG MIN SEC)," (multiple-value-bind (deg minutes) (truncate (* number 60) 60) (multiple-value-bind (min sec) (truncate (* minutes 60) 60) (list deg min sec)))) (defun convert-degrees-minutes-seconds-to-ratio (degrees-minutes-seconds) "DEGREES-MINUTES-SECONDS is of the form \(DEG &OPTIONAL MIN SEC)." (destructuring-bind (deg &optional (min 0) (sec 0)) degrees-minutes-seconds (+ deg (/ min 60) (/ sec 3600)))) (defun convert-to-longitude (x) "Return (SIGN RATIO) denoting an angle between 0 and 30 in SIGN. X can be in any of the following forms: DEG, \(DEG &optional MIN SEC), denoting a longitude in the zodiac between 0 and 360, or \(SIGN DEG &optional MIN SEC) denoting an angle between 0 and 30 in SIGN." (etypecase x (number (assert (<= 0 x)) (assert (< x 360)) (multiple-value-bind (div rem) (truncate x 30) (check-type div (integer 0 11)) (list (nth div +signs+) rem))) (cons (etypecase (car x) (number (convert-to-longitude (convert-degrees-minutes-seconds-to-ratio x))) (symbol (destructuring-bind (sign . dms) x (assert (find sign +signs+)) (list sign (convert-degrees-minutes-seconds-to-ratio dms)))))))) (defun convert-longitude-to-zodiac-longitude (x) (+ (car (get (car x) :zodiac-interval)) (cadr x))) (defun convert-longitude-to-degrees-minutes-seconds (x) (cons (car x) (convert-ratio-to-degrees-minutes-seconds (cadr x)))) (defun zodiac-longitude-lies-in-range (x lo hi) (if (= lo hi) (= lo x) (if (< lo hi) (and (<= lo x) (< x hi)) (or (and (<= lo x) (<= x 360) (<= 0 hi)) (and (<= lo 360) (<= 0 x) (< x hi)))))) (defun longitude-lies-in-range (longitude range) "Range is a list (LO HI) of longitudes." (destructuring-bind (x lo hi) (mapcar (lambda (x) (convert-longitude-to-zodiac-longitude (convert-to-longitude x))) (list longitude (car range) (cadr range))) (zodiac-longitude-lies-in-range x lo hi))) ;;; ---------------------------------------------------------------------- ;;; ;;; (export '(house+ opposite-sign-of)) (defun opposite-sign-of (sign) (elt +signs+ (mod (+ (get sign :number) 5) 12))) (defun house+ (a b) "Bth house counted from house A." (check-type a (integer 1 12)) (let ((x (mod (+ a b -1) 12))) (if (zerop x) 12 x))) (defun ks-ayanamsa (year) "Final as per K.Subramaniam. 2003." (+ 22 (/ (+ 1350 (* (- year 1900) 50.2388475)) (+ 3600 (/ (* (- year 1900) (- year 1900) 0.000111) 3600))))) ;;; ---------------------------------------------------------------------- ;;; ;;; EXALTATION DEBILITATION AND MOOLTRIKONA SIGNS & DEGREES OF PLANETS (HINDU) ;;; (defvar +planetary-states+ ;; (planet exaltation-longitude moolatrikona-longitude debilitation-sign . own-signs) '((Ketu (Sagittarius 15) (Scorpio 15) Gemini Virgo) ;;(Ketu (Scorpio 20) (Pisces 15) Taurus ?) ;;(Venus (Pisces 20) (libra 20) Virgo Libra Taurus) (Venus (Pisces 27) (libra 15) Virgo Libra Taurus) (Sun (Aries 10) (Leo 20) Libra Leo) (Moon (Taurus 3) (Taurus 20) Scorpio Cancer) (Mars (Capricorn 28) (Aries 12) Cancer Scorpio Aries) (Rahu (Gemini 15) (Taurus 15) Sagittarius Pisces) ;;(Rahu (Taurus 20) (Virgo 15) Scorpio ?) (Jupiter (Cancer 5) (Sagittarius 10) Capricorn Sagittarius Pisces) (Saturn (Libra 20) (Aquarius 20) Aries Capricorn Aquarius) (Mercury (Virgo 15) (Virgo 20) Pisces Gemini Virgo))) ;; XXX Sun's Moolatrikona = 4-20 leo? (defun compute-own-signs (planet) (nthcdr 4 (assoc planet +planetary-states+))) (defun compute-exaltation-sign (planet) (car (second (assoc planet +planetary-states+)))) (defun compute-moolatrikona-sign (planet) (car (third (assoc planet +planetary-states+)))) (defun compute-debilitation-sign (planet &aux x) (prog1 (setq x (fourth (assoc planet +planetary-states+))) (unless (find planet '(rahu ketu)) (assert (eql x (opposite-sign-of (compute-exaltation-sign planet))))))) (defun compute-exaltation-longitudes (planet) "Returns a range of the form (LO HI) where LO HI are longitudes." (let ((e (second (assoc planet +planetary-states+)))) (when e (list (list (car e) 0) e)))) (defun compute-debilitation-longitudes (planet) (mapcar (lambda (x) (cons (compute-debilitation-sign planet) (cdr x))) (compute-exaltation-longitudes planet))) (defun compute-moolatrikona-longitudes-list (planet) "Returns a list of ranges of the form ((LO HI)) where LO HI are longitudes." (let ((e1 (second (assoc planet +planetary-states+))) (m2 (third (assoc planet +planetary-states+)))) (when (and e1 m2) (if (eql (car m2) (car e1)) (list (list (list (car e1) (cadr e1)) m2)) (list (list (list (car e1) (cadr e1)) (list (car e1) 30)) (list (list (car m2) 0) m2)))))) (defun compute-own-longitudes-list (planet) "Returns a list of ranges of the form ((LO HI)) where LO HI are longitudes." (let ((e1 (second (assoc planet +planetary-states+))) (m2 (third (assoc planet +planetary-states+)))) (mapcar (lambda (sign) (if (eql (car e1) sign) (if (eql (car m2) sign) (list (list sign (max (cadr e1))) (list sign (cadr m2)) 30) (list (list sign (cadr e1)) (list sign 30))) (if (eql (car m2) sign) (list (list sign (cadr m2)) (list sign 30)) (list (list sign 0) (list sign 30))))) (nthcdr 4 (assoc planet +planetary-states+))))) (mapcar (lambda (planet) (setf (get planet :exaltation-sign) (compute-exaltation-sign planet) (get planet :moolatrikona-sign) (compute-moolatrikona-sign planet) (get planet :debilitation-sign) (compute-debilitation-sign planet) (get planet :exaltation-longitudes) (compute-exaltation-longitudes planet) (get planet :debilitation-longitudes) (compute-debilitation-longitudes planet) (get planet :own-longitudes-list) (compute-own-longitudes-list planet) (get planet :moolatrikona-longitudes-list) (compute-moolatrikona-longitudes-list planet))) +planets+) ;;; ---------------------------------------------------------------------- ;;; ;;; INTERPLANETARY NAISARGIKA RELATIONSHIPS (HINDU) ;;; (defvar *naisargika-ambiguity-rahu-ketu-own-planets-p* t) (defun compute-sign-owners (sign &aux x) (if *naisargika-ambiguity-rahu-ketu-own-planets-p* (prog1 (setq x (mapcar 'car (remove-if-not (lambda (x) (find sign (nthcdr 4 x))) +planetary-states+))) (assert (find (get sign :ruler) x))) (list (get sign :ruler)))) (defvar *naisargika-ambiguity-exclude-exaltation-lord-from-enemies* t) (defun compute-naisargika-relations (planet) "Return a list of \(Friends Neutrals Enemies). From the moolatrikona sign of a planet the 2nd, 4th, 5th, 8th, 9th, and 12th position lords are its friends and the rest are its enemies. If a planet is both a friend and anemy it is considered a neutral. The exaltation sign's lord of a planet is always its friend. THE RELATION IS NOT SYMMETRIC." (let ((exaltation-sign (compute-exaltation-sign planet)) ret ret-friends ret-enemies ret-neutrals) (when exaltation-sign (loop for sign in (relist +signs+ (compute-moolatrikona-sign planet)) for i from 1 do (loop for other-planet in (compute-sign-owners sign) for cons = (or (assoc other-planet ret) (car (push (list other-planet) ret))) unless (eql planet other-planet) do (cond ((find i '(2 4 5 8 9 12)) (incf (getf (cdr cons) :friends 0))) ((find i '(3 6 7 10 11)) (incf (getf (cdr cons) :enemies 0))) ((= i 1) #+nil (incf (getf (cdr cons) :enemies 0))) ((error "Sanity"))) (if (eql sign exaltation-sign) (incf (getf (cdr cons) :exaltation-sign-lord 0)))))) (loop for (other-planet . rest) in ret do (destructuring-bind (&key friends enemies exaltation-sign-lord) rest (cond ((eql other-planet planet)) (exaltation-sign-lord (assert (= exaltation-sign-lord 1)) (cond ((and enemies *naisargika-ambiguity-exclude-exaltation-lord-from-enemies*) (pushnew other-planet ret-neutrals)) (t (pushnew other-planet ret-friends)))) ((and friends enemies) (pushnew other-planet ret-neutrals)) (friends (pushnew other-planet ret-friends)) (enemies (pushnew other-planet ret-enemies)) ((error "Sanity"))))) (values (mapcar (lambda (x) (sort x #'string< :key 'symbol-name)) (list ret-friends ret-neutrals ret-enemies)) ret))) ;;; ---------------------------------------------------------------------- ;;; ;;; (defun compute-star-at (longitude) "LONGITUDE is of the form (SIGN N) where N is a ratio between 0 and 30 in SIGN. Return the star wherein zone lies the given longitude." ;; Texas A&M Freshman: Say, buddy, can you tell me where the library is at? ;; Princeton upperclassman: My good fellow, at Princeton we do not end our ;; sentences with a preposition. ;; Freshman: All right, can you tell me where the library is at, asshole? (destructuring-bind (sign ratio) longitude (assert (find sign +signs+)) (loop for (star . plist) in (get sign :zones) for interval = (getf plist :interval) do (assert (eq sign (car interval))) (destructuring-bind (beg end) (cdr interval) (when (< beg ratio end) (return star)))))) (defun compute-sub-at (longitude) "LONGITUDE is of the form (SIGN N) where N is a ratio between 0 and 30 in SIGN. Return the planet ruling the sub division under the KP system of the star at the given longitude." (destructuring-bind (sign ratio) longitude (loop for (sublord . plist) in (get (compute-star-at longitude) :subs) for interval = (getf plist :interval) when (eq sign (car interval)) do (destructuring-bind (beg end) (cdr interval) (when (< beg ratio end) (return sublord)))))) ;;; ---------------------------------------------------------------------- ;;; ;;; PROGRESSIONS ;;; (defun compute-vimshottari-dasas (first-dasa &optional (time-cycle-in-years 120)) "Internal. Return an alist of (PLANET . YEARS). Use TIME-CYCLE-IN-YEARS when computing subdivisions BHUKTI, ANTARA, etc." (mapcar (lambda (planet) (cons planet (* (get planet :vimshottari-ratio) 1/120 time-cycle-in-years))) (relist +planets+ first-dasa))) (defun compute-vimshottari-mahadasa-and-fraction-remaining-at (longitude) "Internal. LONGITUDE is of the form \(SIGN N) where N is a ratio between 0 and 30 in SIGN. Return (PLANET FRACTION) where PLANET rules the first dasa and FRACTION is a number between 0 and 1 denoting the remaining period of the first dasa." (destructuring-bind (sign deg) longitude (let* ((zodiac-longitude (+ deg (* 30 (1- (get sign :number))))) (star (compute-star-at longitude))) (list (get star :ruler) (* (- (cadr (get star :zodiac-interval)) zodiac-longitude) 3/40))))) (defun compute-vimshottari-mahadasas-at (longitude &optional (time-cycle-in-years 120) &aux x) "Return an alist of (PLANET . YEARS). LONGITUDE is of the form \(SIGN N) where N is a ratio between 0 and 30 in SIGN." (destructuring-bind (first-dasa fraction-of-first-dasa-remaining) (compute-vimshottari-mahadasa-and-fraction-remaining-at longitude) (prog1 (setq x (compute-vimshottari-dasas first-dasa time-cycle-in-years)) (rplacd (car x) (* (cdar x) fraction-of-first-dasa-remaining))))) (defun compute-vimshottari-subperiod-dasas (mahadasa-alist &optional subperiods) "First return value is the cumulative offset in years to the beginning of the subperiod. Second value is an alist of (PLANET . FRACTIONAL-YEARS). SUBPERIODS is a list of planets of the form \(DASA &optional BHUKTI ANTHARA ...). If SUBPERIODS is NIL just return the Mahadasa-alist. " (let ((cum-years 0) (cur-time-cycle 120) (dasa-alist mahadasa-alist)) (loop for period-ruler in subperiods do (loop for (planet . fractional-years) in dasa-alist when (eql planet period-ruler) do (setq cur-time-cycle (* cur-time-cycle 1/120 (get period-ruler :vimshottari-ratio)) dasa-alist (compute-vimshottari-dasas period-ruler cur-time-cycle)) (return) else do (incf cum-years fractional-years) finally (error "Sanity."))) (values cum-years dasa-alist))) ;;; ---------------------------------------------------------------------- ;;; ;;; PRINTING THE SOUTH INDIAN CHART IN ASCII ;;; ;;; +-+-+-+-+ ;;; |c|1|2|3| ;;; +-+-+-+-+ ;;; |b| |4| ;;; +-+ 0 +-+ ;;; |a| |5| ;;; +-+-+-+-+ ;;; |9|8|7|6| ;;; +-+-+-+-+ (defun printed-chart-bounds-of-box-at (printed-chart position) "Return (ROW-START COL-START HEIGHT WIDTH)." (destructuring-bind (total-height total-width) (array-dimensions printed-chart) (let* ((box-height (/ (- total-height 5) 4)) (box-width (/ (- total-width 5) 4)) (col1 (+ (* 0 box-width) 1)) (row1 (+ (* 0 box-height) 1)) (col2 (+ (* 1 box-width) 2)) (row2 (+ (* 1 box-height) 2)) (col3 (+ (* 2 box-width) 3)) (row3 (+ (* 2 box-height) 3)) (col4 (+ (* 3 box-width) 4)) (row4 (+ (* 3 box-height) 4))) (ecase position (#x0 (list row2 col2 (+ (* 2 box-height) 1) (+ (* 2 box-width) 1))) (#xc (list row1 col1 box-height box-width)) (#xb (list row2 col1 box-height box-width)) (#xa (list row3 col1 box-height box-width)) (#x9 (list row4 col1 box-height box-width)) (#x1 (list row1 col2 box-height box-width)) (#x2 (list row1 col3 box-height box-width)) (#x3 (list row1 col4 box-height box-width)) (#x4 (list row2 col4 box-height box-width)) (#x5 (list row3 col4 box-height box-width)) (#x6 (list row4 col4 box-height box-width)) (#x7 (list row4 col3 box-height box-width)) (#x8 (list row4 col2 box-height box-width)))))) (defun printed-chart-clear-box-at (printed-chart position) (destructuring-bind (row-start col-start height width) (printed-chart-bounds-of-box-at printed-chart position) (loop for y from row-start repeat height do (loop for x from col-start repeat width do (setf (aref printed-chart y x) #\Space))))) (defun printed-chart-write-lines-to-box-at (lines printed-chart position &key (valign :top) (align :left) &aux (nrows (length lines))) (destructuring-bind (row-start col-start height width) (printed-chart-bounds-of-box-at printed-chart position) (ecase valign (:top) (:middle (let ((nblanks (- height nrows))) (when (plusp nblanks) (incf row-start (floor nblanks 2)) (decf height nblanks)))) (:bottom (let ((nblanks (- height nrows))) (when (plusp nblanks) (incf row-start nblanks) (decf height nblanks))))) (loop for col-start1 = col-start and width1 = width for y from row-start repeat height for line in lines for length = (length line) do (ecase align (:left) (:center (let ((nblanks (- width length))) (when (plusp nblanks) (incf col-start1 (floor nblanks 2)) (decf width1 nblanks)))) (:right (let ((nblanks (- width length))) (when (plusp nblanks) (incf col-start1 nblanks) (decf width1 nblanks))))) (loop for x from col-start1 repeat width1 for char across line do (setf (aref printed-chart y x) char))))) (defun initialize-printed-chart (printed-chart) (destructuring-bind (height width) (array-dimensions printed-chart) (let* ((box-height (/ (- height 5) 4)) (box-width (/ (- width 5) 4)) (row1 (+ (* box-height 0) 0)) (col1 (+ (* box-width 0) 0)) (row2 (+ (* box-height 1) 1)) (col2 (+ (* box-width 1) 1)) (row3 (+ (* box-height 2) 2)) (col3 (+ (* box-width 2) 2)) (row4 (+ (* box-height 3) 3)) (col4 (+ (* box-width 3) 3)) (row5 (+ (* box-height 4) 4)) (col5 (+ (* box-width 4) 4)) (rows (list row1 row2 row3 row4 row5)) (cols (list col1 col2 col3 col4 col5))) (loop for y below height do (loop for x below width for rowp = (position y rows) and colp = (position x cols) do (setf (aref printed-chart y x) (if (and (< col2 x col4) (< row2 y row4)) #\Space (if rowp (if colp #\+ #\-) (if colp #\| #\Space))))))))) (defun print-printed-chart (printed-chart &optional (stream *standard-output*)) (destructuring-bind (height width) (array-dimensions printed-chart) (loop for y below height do (loop for x below width do (princ (aref printed-chart y x) stream)) (terpri stream)))) (defun make-printed-chart (&optional (box-height 3) (box-width 5)) (let ((retval (make-array(list (+ (* 4 box-height) 5) (+ (* 4 box-width) 5)) :element-type 'Character :initial-element #\Space))) (initialize-printed-chart retval) retval)) (defun compute-bbox (list &optional (height 0) (width 0)) "Return (HEIGHT WIDTH) of largest box. LIST is of the form \((LINES) ...)" (loop for item in list do (loop for line in item do (if (> (length line) width) (setq width (length line))) count 1 into nlines finally (if (> nlines height) (setq height nlines)))) (list height width)) (defun ensure-princable (rows) "Rows is a list of lists of the form ((item1 item2 .. ) ... )." (mapcar (lambda (x) (mapcar (lambda (x) (if (stringp x) x (princ-to-string x))) x)) rows)) ;; Example: (defun print-chart (rows &optional (stream *standard-output*)) "Internal. Rows is a list of 12 elements, each element is a list of lines to be printed inside a box at that position in the south indian chart." (let ((list (ensure-princable rows))) (destructuring-bind (height width) (compute-bbox list) (let ((pc (make-printed-chart height width))) (loop for i from 1 for lines in list do (printed-chart-write-lines-to-box-at lines pc i :valign :middle :align :center)) (print-printed-chart pc stream))))) ;; Example: (defun print-table (rows &optional (stream *standard-output*)) "Internal. Rows is a list of lists of the form ((item1 item2 .. ) ... )." (setq rows (ensure-princable rows)) (let* ((widths (mapcar (lambda (x) (+ 2 (cadr x))) (mapcar 'compute-bbox (mapcar (lambda (x) (mapcar 'list x)) (apply #'mapcar #'list rows)))))) (map nil (lambda (x) (map nil (lambda (w x) (format stream "~v@<~A~>" w x)) widths x) (terpri stream)) rows))) ;;; ---------------------------------------------------------------------- ;;; ;;; EXAMPLE: ;;; #|| #+nil (print-chart (loop for sign in +signs+ for house-number from 1 to 12 collect (list sign (get sign :ruler)))) #+nil (defvar $chart-data ;p139a '((Ascendant (Scorpio 15 46 03)) (Sun (Taurus 12 23 53)) (Moon (Aquarius 07 31 13)) (Mars (Gemini 02 45 42)) (Mercury (Aries 20 48 19)) (Jupiter (Libra 3 41 13)) (Venus (Gemini 12 31 40)) (Saturn (Aries 21 47 49)) (Rahu (Aquarius 1 01 22)) (Ketu (Leo 14 01 22)))) (defun find-lagna-sign (chart-data) (car (convert-to-longitude (cadr (assoc 'Ascendant chart-data ))))) (defun group-planets-by-sign (chart-data) "Return an alist of (SIGN . PLANETS). The elements are sorted in the order of the houses, starting from the lagna." (let ((signs-alist (mapcar 'list (relist +signs+ (find-lagna-sign chart-data))))) (loop for (planet x) in chart-data do (destructuring-bind (sign longitude) (convert-to-longitude x) (declare (ignore longitude)) (pushnew planet (cdr (assoc sign signs-alist))))) signs-alist)) (defun print-south-indian-chart (chart-data) (let* ((signs-alist (group-planets-by-sign chart-data)) (lines-list (loop for (sign . planets) in signs-alist collect (mapcar 'princ-to-string (reverse planets))))) (destructuring-bind (height width) (compute-bbox lines-list) (let ((pc (make-printed-chart height width))) (mapcar (lambda (lines sign) (printed-chart-write-lines-to-box-at lines pc (get (car sign) :number) :valign :middle :align :center)) lines-list signs-alist) (print-printed-chart pc))))) #+nil (print-south-indian-chart $chart-data) ||# ;;; ---------------------------------------------------------------------- ;;; ;;; FIXED COLUMN PARSING ;;; (defvar *column-specs* nil "column-spec = ((start stop) indicator)") (defun column-lookup-index (line indicator list &optional (column-specs *column-specs*)) "Return index of entity at position in LINE denoted by INDICATOR in LIST." (destructuring-bind (start end) (car (rassoc (list indicator) column-specs :test #'equal)) (loop for name across list for l = (length name) for i from 0 if (and (= l (- end start)) (<= end (length line)) (string-equal line name :start1 start :end1 end)) return i))) (defun column-parse-integer (line indicator &optional (column-specs *column-specs*)) "Return integer at position in LINE denoted by INDICATOR." (destructuring-bind (start end) (car (rassoc (list indicator) column-specs :test #'equal)) (when (<= end (length line)) (parse-integer line :start start :end end)))) (defun column-parse-float (line indicator &optional (column-specs *column-specs*)) "Return float at position in LINE denoted by INDICATOR." (destructuring-bind (start end) (car (rassoc (list indicator) column-specs :test #'equal)) (when (<= end (length line)) (let ((float (read-from-string line t nil :start start :end end))) (check-type float number) float)))) ;;; ---------------------------------------------------------------------- ;;; ;;; PARSE ASTROLOG 5.40 OUTPUT ;;; ;;; Use Walter Pullet's excellent astrolog-5.40 program to compute chart data. ;;; Use Sidereal zodiac with '=s' 0.98333, krishnamurthy ayanamsa, Ephemeris ;;; files, and Placidus Houses. ;;; ;;; astrolog '=b' '=s' 0.98333 /qa "Jun 21 2001 11:35am +00:00 106:39W 35:05N" ;;; ;;; 012345678901234567890123456789012345678901234567890123456789012345678901234567 ;;; Satu: 14Tau01 - 1:41' (-) [12th house] [-] +0.123 - House cusp 7: 1Sag10 ;;; (export '(ast54-parse-chart)) (defvar +ast54-sign-names+ #("Ari" "Tau" "Gem" "Can" "Leo" "Vir" "Lib" "Sco" "Sag" "Cap" "Aqu" "Pis")) (defvar +ast54-chart-columns+ ;; (start end) indicator '(((0 4) planet-name) ((6 8) planet-sign-degrees) ((8 11) planet-sign-name) ((11 13) planet-sign-minutes) ((29 31) planet-house-number) ((67 69) house-cusp-house-number) ((71 73) house-cusp-degrees) ((73 76) house-cusp-sign) ((76 78) house-cusp-minutes))) (defvar +ast54-chart-row-specs+ ;; match-string identifier row '(("Venu" Venus 6) ("Sun " Sun 3) ("Moon" Moon 4) ("Mars" Mars 7) ("Node" Rahu 18) ("Jupi" Jupiter 8) ("Satu" Saturn 9) ("Merc" Mercury 5))) (defvar +ast54-planet-names+ (apply 'vector (mapcar (lambda (x) (car x)) +ast54-chart-row-specs+))) (defvar +ast54-planet-identifiers+ (apply 'vector (mapcar (lambda (x) (cadr x)) +ast54-chart-row-specs+))) (defvar +ast54-planet-rows+ (apply 'vector (mapcar (lambda (x) (caddr x)) +ast54-chart-row-specs+))) (defun ast54-decompose-planet-info (line &optional row (*column-specs* +ast54-chart-columns+)) "Return (PLANET LONGITUDE)." (let ((planet-index (column-lookup-index line 'planet-name +ast54-planet-names+))) (when planet-index (when row (assert (= row (elt +ast54-planet-rows+ planet-index)))) (list (elt +ast54-planet-identifiers+ planet-index) (list (elt +signs+ (column-lookup-index line 'planet-sign-name +ast54-sign-names+)) (column-parse-integer line 'planet-sign-degrees) (column-parse-integer line 'planet-sign-minutes)))))) (defun ast54-decompose-house-cusp-info (line &optional row (*column-specs* +ast54-chart-columns+)) "Return (HOUSE-NUMBER CUSP-LONGITUDE)." (let ((house-number (column-parse-integer line 'house-cusp-house-number))) (when row (assert (= house-number (- row 2)))) (list house-number (list (elt +signs+ (column-lookup-index line 'house-cusp-sign +ast54-sign-names+)) (column-parse-integer line 'house-cusp-degrees) (column-parse-integer line 'house-cusp-minutes))))) (defun ast54-parse-chart (file) "Returns chart data in the form of a list of \(PLANET-SYMBOL LONGITUDE) and \(HOUSE-NUMBER CUSP-LONGITUDE)." (with-open-file (stream file) (loop for row from 0 for line = (or (read-line stream nil nil) (loop-finish)) when (and (>= row 3) (ast54-decompose-planet-info line row)) collect it when (and (<= 3 row 14) (ast54-decompose-house-cusp-info line row)) collect it))) ;;; ---------------------------------------------------------------------- ;;; ;;; PARSE SWISS EPHEMERIS OUTPUT (SWE-1.75.00) ;;; ;;; ./swetest -sid5 -pd -house -hsyp -fPZj -edir$EPHEM -ut11:35:00 -topo-106.65,35.0834,995 -b21.06.2001 ;;; ;;; 01234567890123456789012345678901234567890123 ;;; Saturn 14 ta 1'13.4519 11.9492320 ;;; (export '(swe-parse-chart)) (defvar +swe-sign-names+ #("ar" "ta" "ge" "cn" "le" "vi" "li" "sc" "sa" "cp" "aq" "pi")) (defvar +swe-chart-columns+ '(((0 16) object-name) ((16 18) object-degree) ((19 21) object-sign) ((22 24) object-minutes) ((25 32) object-seconds) ((34 36) object-house-number))) (defvar +swe-chart-row-specs+ '(("Sun " Sun) ("Moon " Moon) ("Mercury " Mercury) ("Venus " Venus) ("Mars " Mars) ("Jupiter " Jupiter) ("Saturn " Saturn ) ("mean Node " Rahu) #+nil ("true Node " Rahu) ("house 1 " 1) ("house 2 " 2) ("house 3 " 3) ("house 4 " 4) ("house 5 " 5) ("house 6 " 6) ("house 7 " 7) ("house 8 " 8) ("house 9 " 9) ("house 10 " 10) ("house 11 " 11) ("house 12 " 12) ("Uranus " :Uranus) ("Neptune " :Neptune) #+nil ("Pluto " :Pluto))) (defvar +swe-object-names+ (apply 'vector (mapcar (lambda (x) (car x)) +swe-chart-row-specs+))) (defvar +swe-object-identifiers+ (apply 'vector (mapcar (lambda (x) (cadr x)) +swe-chart-row-specs+))) (defun swe-decompose-line-info (line &optional (*column-specs* +swe-chart-columns+)) "Return (HOUSE-OR-PLANET LONGITUDE-DESIGNATOR)." (let ((obj-index (column-lookup-index line 'object-name +swe-object-names+))) (when obj-index (let ((obj-identifier (elt +swe-object-identifiers+ obj-index))) (check-type obj-identifier (or symbol (integer 1 12))) (list obj-identifier (list (elt +signs+ (column-lookup-index line 'object-sign +swe-sign-names+)) (column-parse-integer line 'object-degree) (column-parse-integer line 'object-minutes) (column-parse-float line 'object-seconds))))))) (defun swe-parse-chart (file) "Returns chart data in the form of a list of \(PLANET-SYMBOL LONGITUDE) and \(HOUSE-NUMBER CUSP-LONGITUDE)." (with-open-file (stream file) (loop for line = (or (read-line stream nil nil) (loop-finish)) when (swe-decompose-line-info line) collect it))) ;;; ---------------------------------------------------------------------- ;;; ;;; (defun chart-data-get-fortuna (chart-data) "Compute the sensitive point which is equally distant from the lagna as the moon is from the sun." (destructuring-bind (moon-zl sun-zl lagna-zl) (mapcar (lambda (x) (convert-longitude-to-zodiac-longitude (convert-to-longitude (cadr x)))) (list (assoc 'Moon chart-data) (assoc 'Sun chart-data) (assoc 'Ascendant chart-data))) (let ((offset (if (> moon-zl sun-zl) (- moon-zl sun-zl) (+ moon-zl (- 360 sun-zl))))) (list 'Fortuna (convert-to-longitude (mod (+ offset lagna-zl) 360)))))) (defun chart-data-get-lagna (chart-data) "Compute Lagna from 1st house cusp" (let ((1st-cons (assoc 1 chart-data))) (assert 1st-cons) (list 'Ascendant (second 1st-cons)))) (defun chart-data-get-ketu (chart-data) "Compute Ketu from positio of Rahu." (let ((rahu-cons (assoc 'rahu chart-data))) (assert rahu-cons) (destructuring-bind ((rahu-sign . rahu-degrees)) (cdr rahu-cons) (list 'Ketu (cons (opposite-sign-of rahu-sign) rahu-degrees))))) (defun locate-house-number (longitude house-cusps) "Return the number between 1 to 12 denoting the house in which LONGITUDE falls. Assume each house starts at its cusp. HOUSE-CUSPS is a list of longitudes of house cusps starting at the first house." (loop for (cusp . rest) on house-cusps for house-number from 1 if (longitude-lies-in-range longitude (list cusp (if rest (car rest) (car house-cusps)))) return house-number)) ;;; ---------------------------------------------------------------------- ;;; ;;; CHART-INFO ;;; (export '(chart-info *chart-info* make-chart-info lord-of-sign longitude-of-cusp sign-of-cusp star-of-cusp lord-of-star-of-cusp lord-of-sub-of-cusp house-of-planet longitude-of-planet sign-of-planet star-of-planet lord-of-star-of-planet lord-of-sub-of-planet lord-of-house-cusp planets-in-house planets-in-sign)) (defclass chart-info-cache-mixin () ((cache :initform nil :accessor cache))) (defmacro caching-value ((indicator argument chart-info) &body body) ; memo (check-type indicator symbol) (check-type argument symbol) (check-type chart-info symbol) `(with-slots (cache) ,chart-info (let ((cons (or (assoc ',indicator cache) (car (push (list ',indicator) cache))))) (or (getf (cdr cons) ,argument) (setf (getf (cdr cons) ,argument) (progn ,@body)))))) (defclass chart-info (chart-info-cache-mixin) (planet-longitude-alist house-planets house-cusps)) (defun make-chart-info (chart-data &key simple-chart-p &aux x) "SIMPLE-CHART-P if non NIL indicates we should not compute house position. Use this option when CHART-DATA does not have any house cusp information." (unless simple-chart-p (unless (assoc 'Ascendant chart-data) (push (chart-data-get-lagna chart-data) chart-data)) (unless (assoc 'Ketu chart-data) (when (assoc 'Rahu chart-data) (push (chart-data-get-ketu chart-data) chart-data))) (unless (assoc 'Fortuna chart-data) (push (chart-data-get-fortuna chart-data) chart-data))) (prog1 (setq x (make-instance 'chart-info)) (with-slots (planet-longitude-alist house-planets house-cusps) x (setq house-cusps (make-list 12) house-planets (make-list 12) planet-longitude-alist (loop for elem in chart-data if (symbolp (car elem)) collect (destructuring-bind (planet longitude &rest rest) elem (declare (ignore rest)) (cons planet (convert-to-longitude longitude))) if (numberp (car elem)) do (destructuring-bind (house-number longitude) elem (check-type house-number (integer 1 12)) (setf (elt house-cusps (1- house-number)) (convert-to-longitude longitude))))) (unless simple-chart-p (loop for (planet . longitude) in planet-longitude-alist do (pushnew planet (elt house-planets (1- (locate-house-number longitude house-cusps))))))))) (defvar *chart-info* nil) (defun simple-chart-p (&optional (chart-info *chart-info*)) (null (elt (slot-value chart-info 'house-cusps) 0))) (defun longitude-of-cusp (n &optional (chart-info *chart-info*)) (with-slots (house-cusps) chart-info (elt house-cusps (1- n)))) (defun sign-of-cusp (n &optional (chart-info *chart-info*)) (car (longitude-of-cusp n chart-info))) (defun star-of-cusp (n &optional (chart-info *chart-info*)) (caching-value (star-of-cusp n chart-info) (compute-star-at (longitude-of-cusp n chart-info)))) (defun lord-of-star-of-cusp (n &optional (chart-info *chart-info*)) (caching-value (lord-of-star-of-cusp n chart-info) (get (star-of-cusp n chart-info) :ruler))) (defun lord-of-sub-of-cusp (n &optional (chart-info *chart-info*)) (caching-value (lord-of-sub-of-cusp n chart-info) (compute-sub-at (longitude-of-cusp n chart-info)))) (defun house-of-planet (planet &optional (chart-info *chart-info*)) (caching-value (house-of-planet planet chart-info) (with-slots (house-planets) chart-info (1+ (position-if (lambda (planets) (find planet planets)) house-planets))))) (defun longitude-of-planet (planet &optional (chart-info *chart-info*)) (with-slots (planet-longitude-alist) chart-info (cdr (assoc planet planet-longitude-alist)))) (defun sign-of-planet (planet &optional (chart-info *chart-info*)) (car (longitude-of-planet planet chart-info))) (defun star-of-planet (planet &optional (chart-info *chart-info*)) (caching-value (star-of-planet planet chart-info) (compute-star-at (longitude-of-planet planet chart-info)))) (defun lord-of-sign (sign) (get sign :ruler)) (defun lord-of-star-of-planet (planet &optional (chart-info *chart-info*)) (caching-value (lord-of-star-of-planet planet chart-info) (get (star-of-planet planet chart-info) :ruler))) (defun lord-of-sub-of-planet (planet &optional (chart-info *chart-info*)) (caching-value (lord-of-sub-of-planet planet chart-info) (compute-sub-at (longitude-of-planet planet chart-info)))) (defun lord-of-house-cusp (n &optional (chart-info *chart-info*)) ; kp "Lord of the sign in which cusp of the Nth house falls." (get (sign-of-cusp n chart-info) :ruler)) (defun lord-of-house-hindu (n &optional (chart-info *chart-info*)) "Lord of the sign at house position N in vedic house system, with respect to the Lagna." (get (elt +signs+ (1- (house+ (get (sign-of-cusp 1 chart-info) :number) n))) :ruler)) (defun planets-in-house (n &optional (chart-info *chart-info*)) (check-type n (integer 1 12)) (with-slots (house-planets) chart-info (elt house-planets (1- n)))) (defun planets-in-sign (sign &optional (chart-info *chart-info*)) (assert (find sign +signs+)) (caching-value (planets-in-sign sign chart-info) (with-slots (planet-longitude-alist) chart-info (loop for (planet . longitude) in planet-longitude-alist if (eql sign (car longitude)) collect planet)))) ;;; ---------------------------------------------------------------------- ;;; ;;; UTILITIES: HANDLE DATES FROM 31/12/1BC. (UNTESTED, ADAPTED FROM REINGOLD) ;;; (defun gregorian-leap-year-p (year) (and (zerop (mod year 4)) (or (not (zerop (mod year 100))) (zerop (mod year 400))))) (defun encode-gregorian-date (second minute hour day month year &optional time-zone) "COPYRIGHT REINGOLD from where this is adapted. Returns the fractional number of days elapsed since Sun Dec 31 1BC." (+ (* 365 (1- year)) (floor (1- year) 4) (- (floor (1- year) 100)) (floor (1- year) 400) (floor (- (* 367 month) 362) 12) (if (<= month 2) 0 (if (gregorian-leap-year-p year) -1 -2)) day (/ (+ second (* 60 minute) (* 3600 (if time-zone (- hour time-zone) hour))) 86400))) (defun decode-gregorian-date (gregorian-date &optional time-zone) "COPYRIGHT REINGOLD from where this is adapted. GREGORIAN-DATE is the fractional number of days since 12/31/1BC." (when time-zone (decf gregorian-date (/ time-zone 24))) (multiple-value-bind (date frac) (floor gregorian-date) (let* ((d0 (- date 1)) (n400 (floor d0 146097)) (d1 (mod d0 146097)) (n100 (floor d1 36524)) (d2 (mod d1 36524)) (n4 (floor d2 1461)) (d3 (mod d2 1461)) (n1 (floor d3 365)) (y0 (+ (* 400 n400) (* 100 n100) (* 4 n4) n1)) (year (if (or (= n100 4) (= n1 4)) y0 (1+ y0))) (prior-days (- date (encode-gregorian-date 0 0 0 1 1 year))) (correction (if (< date (encode-gregorian-date 0 0 0 1 2 year)) 0 (if (gregorian-leap-year-p year) 1 2))) (month (floor (+ (* 12 (+ prior-days correction)) 373) 367)) (day (1+ (- date (encode-gregorian-date 0 0 0 1 month year))))) (multiple-value-bind (hour minute1) (floor (* frac 86400) 3600) (multiple-value-bind (minute second) (floor minute1 60) (values (floor second) minute hour day month year (mod (1- (mod date 7)) 7) nil time-zone)))))) (defun gregorian-date-string (gregorian-date &optional time-zone) "If timezone is unspecified Assume UT, Return a string denoting the given GREGORIAN-DATE." (multiple-value-bind (second minute hour day month year weekday dst rational) (decode-gregorian-date gregorian-date time-zone) (declare (ignore dst)) (format nil "~A ~A ~2,' D ~2,'0D:~2,'0D:~2,'0D ~4A~@[ ~A~]" (ecase weekday (6 "Sun") (0 "Mon") (1 "Tue") (2 "Wed") (3 "Thu") (4 "Fri") (5 "Sat")) (ecase month (1 "Jan") (2 "Feb") (3 "Mar") (4 "Apr") (5 "May") (6 "Jun") (7 "Jul") (8 "Aug") (9 "Sep") (10 "Oct") (11 "Nov") (12 "Dec")) day hour minute second year (when rational (format nil "~C~2,'0D~2,'0D" (if (plusp rational) #\- #\+) (abs (truncate rational)) (truncate (* 60 (mod rational 1)))))))) (defun gregorian-date-year+ (start-date years) "Add YEARS to gregorian-date START-DATE." (multiple-value-bind (second minute hour day month year weekday dst rational) (decode-gregorian-date start-date) (declare (ignore dst weekday)) (encode-gregorian-date second minute hour day month (+ year years) rational))) (defun gregorian-date-as-years (gregorian-date) "GREGORIAN-DATE as a fractional year." (multiple-value-bind (second minute hour day month year weekday dst rational) (decode-gregorian-date gregorian-date) (declare (ignore second minute hour day month weekday)) (assert (null dst)) (+ year (/ (- gregorian-date (encode-gregorian-date 0 0 0 1 1 year rational)) (if (gregorian-leap-year-p year) 366 365))))) ;;; ---------------------------------------------------------------------- ;;; ;;; BIRTH DATE AND PROGRESSIONS ;;; (defun chart-info-set-birth-date (second minute hour day month year time-zone &optional (chart-info *chart-info*)) (WITH-SLOTS (CACHE) CHART-INFO (LET ((CONS (OR (ASSOC 'GREGORIAN-BIRTH-DATE CACHE) (CAR (PUSH (LIST 'GREGORIAN-BIRTH-DATE) CACHE))))) (SETF (GETF (CDR CONS) :GREGORIAN-BIRTH-DATE) (encode-gregorian-date second minute hour day month year time-zone))))) (defun gregorian-birth-date (&optional (chart-info *chart-info*)) (caching-value (gregorian-birth-date :gregorian-birth-date chart-info) (error "Protocol: Gregorian birh date must be set separately."))) (defun vimshottari-dasas (&optional subperiods (chart-info *chart-info*)) "First return value is an alist of \(SUBPERIOD-RULER . GREGORIAN-DATE-STRING). Second return value is the gregorian-date-string for the start of this subperiod. SUBPERIODS can be NIL indicating mahadasas, or it should be a list of planets of the form \(BHUKTI &optional ANTARA ...) denoting conjoint rulers of the subperiod." (let ((longitude (longitude-of-planet 'Moon chart-info))) (destructuring-bind (first-ruling-planet fraction-remaining) (compute-vimshottari-mahadasa-and-fraction-remaining-at longitude) (let ((mahadasa-alist (compute-vimshottari-dasas first-ruling-planet))) (multiple-value-bind (offset-years dasa-alist) (compute-vimshottari-subperiod-dasas mahadasa-alist subperiods) (let ((start-date (gregorian-date-year+ (gregorian-birth-date chart-info) (+ offset-years (* (1- fraction-remaining) (cdar mahadasa-alist))))) (cumul-offset 0)) (values (mapcar (lambda (x) (cons (car x) (gregorian-date-string (gregorian-date-year+ start-date (incf cumul-offset (cdr x)))))) dasa-alist) (gregorian-date-string start-date)))))))) ;;; ---------------------------------------------------------------------- ;;; ;;; KP SIGNIFICATORS ;;; ;;; FIXME: Use aspect information to decide rahu/ketu signifiers. ;;; (defun compute-all-kp-significators (&optional (chart-info *chart-info*)) "Return a list of (PLANET HOUSE TYPE) where PLANET indicates matters of HOUSE by virtue of being posited in a constellation the lord (X) of which either owns HOUSE (TYPE = :LORDSHIP) or is posited in HOUSE (TYPE = :OCCUPANCY). According to KP the matters fructify during the period of the planet or when the planet transits a constellation onwed by X." (mapcan (lambda (planet) (let ((nakshatra-lord (lord-of-star-of-planet planet chart-info))) (cons (list planet (house-of-planet nakshatra-lord chart-info) :occupancy) (loop for i from 1 to 12 when (eql (lord-of-house-cusp i chart-info) ;XXX nakshatra-lord) collect (list planet i :lordship))))) +planets+)) (defun all-kp-significators (&optional (chart-info *chart-info*)) (caching-value (all-kp-significators :all-kp-significators chart-info) (compute-all-kp-significators chart-info))) (defun kp-significands-of-planet (planet &optional (chart-info *chart-info*)) (delete-duplicates (mapcar (lambda (x) (car (remove planet x))) (remove-if-not (lambda (x) (eql (car x) planet)) (all-kp-significators chart-info))))) (defun kp-significators-of-house (house &optional (chart-info *chart-info*)) (mapcar (lambda (x) (car (remove house x))) (remove-if-not (lambda (x) (eql (cadr x) house)) (all-kp-significators chart-info)))) ;;; ---------------------------------------------------------------------- ;;; ;;; ;;; (export '(print-chart-info print-rasi-chart print-bhava-chart print-kp-table print-chart-data)) (defun print-bhava-chart (&optional (chart-info *chart-info*) (stream *standard-output*)) (print-chart (loop with x = (get (sign-of-planet 'Ascendant chart-info) :number) for i from 1 to 12 for house-number = (1+ (mod (- i x) 12)) collect (mapcar 'symbol-name (planets-in-house house-number chart-info))) stream)) (defun print-rasi-chart (&optional (chart-info *chart-info*) (stream *standard-output*)) (print-chart (mapcar (lambda (sign) (mapcar 'symbol-name (planets-in-sign sign chart-info))) +signs+) stream)) (defun print-chart-info (&optional (chart-info *chart-info*) (stream *standard-output*)) (let ((lines-list (mapcar (lambda (sign) (cons sign (mapcar (lambda (planet) (cons planet (longitude-of-planet planet chart-info))) (planets-in-sign sign chart-info)))) +signs+))) (loop for i from 2 to 12 for longitude = (longitude-of-cusp i chart-info) for sign1 = (car longitude) do (push (cons i longitude) (cdr (assoc sign1 lines-list)))) (map-into lines-list (lambda (cons) (rplacd cons (sort (cdr cons) (ecase (get (car cons) :number) ((1 2 3 4 5 6) #'<) ((7 8 9 10 11 12) #'>)) :key (lambda (x) (convert-longitude-to-zodiac-longitude (cdr x)))))) lines-list) (print-chart (mapcar (lambda (cons) (destructuring-bind (sign . rest) cons (mapcar (lambda (elem) (destructuring-bind (x . longitude) elem (destructuring-bind (sign1 deg min sec) (convert-longitude-to-degrees-minutes-seconds longitude) (declare (ignore sec)) (assert (eql sign sign1) nil "~S" (list '/= sign sign1)) (if (numberp x) (format nil "~@R ~D:~2,'0D" x deg min) (format nil "~A ~D:~2,'0D" x deg min))))) rest))) lines-list) stream))) (defun make-kp-table-rows (&optional (chart-info *chart-info*)) "Return (BODY/CUSP HOUSE-LORD LORD-OF-STAR LORD-OF-SUB SIGNIFIC-TORS/ANDS)." (nconc (loop for planet in (list* 'Ascendant 'Fortuna +planets+) collect (list planet (lord-of-house-cusp (house-of-planet planet chart-info) chart-info) (lord-of-star-of-planet planet chart-info) (lord-of-sub-of-planet planet chart-info) (kp-significands-of-planet planet chart-info))) (loop for house from 1 to 12 collect (list house (lord-of-house-cusp house chart-info) (lord-of-star-of-cusp house chart-info) (lord-of-sub-of-cusp house chart-info) (kp-significators-of-house house chart-info))))) (defun print-kp-table (&optional (chart-info *chart-info*) (stream *standard-output*)) (print-table (list* (list "BODY/CUSP" "HOUSE-LORD" "STAR-LORD" "SUB-LORD" "SIGNIFICA{TOR/ND}S") (list "---------" "----------" "---------" "--------" "------------------") (mapcar (lambda (x) (mapcar (lambda (x) (string-capitalize (if x (princ-to-string x) "-"))) x)) (make-kp-table-rows chart-info))) stream)) (defun chart-info-data (&optional (chart-info *chart-info*) &aux x) (with-slots (planet-longitude-alist house-planets house-cusps) chart-info (nconc (setq x (loop for (planet . longitude) in planet-longitude-alist collect (list planet longitude nil))) (loop for house-number from 1 to 12 for planets in house-planets for cusp in house-cusps collect (list house-number cusp) do (loop for planet in planets do (setf (third (assoc planet x)) house-number)))))) (defun print-chart-data (&optional (chart-info *chart-info*) (stream *standard-output*) &aux chart-data) (check-type chart-info chart-info) (setq chart-data (chart-info-data chart-info)) (print-table (list* (list "Body/Cusp" "Longitude" "In Star" "House/Planets") (list "---------" "---------" "-------" "-------------") (mapcar (lambda (x) (ecase (length x) (2 (list (car x) (butlast (convert-longitude-to-degrees-minutes-seconds (cadr x))) (star-of-cusp (car x) chart-info) (planets-in-house (car x) chart-info) )) (3 (list (car x) (butlast (convert-longitude-to-degrees-minutes-seconds (cadr x))) (star-of-planet (car x) chart-info) (caddr x))))) chart-data)) stream)) (defun print-house-lords (&optional (chart-info *chart-info*) (stream *standard-output*)) (print-table (list* (list "House" "In Sign" "Vedic Sign Lord" "House Lord" "Planets") (list "-----" "-------" "---------------" "----------" "-------") (mapcar (lambda (house) (list house (sign-of-cusp house chart-info) (lord-of-house-hindu house chart-info) (lord-of-house-cusp house chart-info) (planets-in-house house chart-info))) (loop for i from 1 to 12 collect i))) stream)) ;;; ;;; EXAMPLE: ;;; #|| (setq *chart-info* (make-chart-info (swe-parse-chart "/tmp/p139.2"))) (print-chart-info) (print-rasi-chart) (print-bhava-chart) (print-kp-table) (print-chart-data) (print-kp-significators-table) (chart-info-set-birth-date 0 19 06 29 1 1928 -11/2) (vimshottari-dasas '(sun saturn mars)) ||# ;;; ---------------------------------------------------------------------- ;;; ;;; INTER PLANETARY RELATIONSHIPS (HINDU) ;;; (defun compute-tatkalika-friends (planet &optional (chart-info *chart-info*)) "Return a list of planets. A planet placed in the 2nd, 3rd, 4th, 10th, 11th and 12th from another planet becomes its temporary friend." (let ((planet-sign (sign-of-planet planet chart-info))) (loop for sign in (relist +signs+ planet-sign) for i from 1 if (find i '(2 3 4 10 11 12)) append (planets-in-sign sign chart-info)))) (defun compute-combined-relations (planet &optional (chart-info *chart-info*)) "Return a list of \(Friends Neutrals Enemies) from combined analysis of naisargika relations and tatkalila friendship in a chart according to the following rules: Temporary Friend + Permanent Friend = Intimate Friend (aadi mitra) Temporary Friend + Permanent Enemy = Neutral Temporary Friend + Permanent Neutral = Friend Temporary Enemy + Permanent Friend = Neutral Temporary Enemy + Permanent Neutral = Enemy Temporary Enemy + Permanent Enemy = Bitter Enemy (aadi \"satru) " (multiple-value-bind (list ret) (compute-naisargika-relations planet) (destructuring-bind (friends neutrals enemies) list (when ret (let ((tatkalika-friends (compute-tatkalika-friends planet chart-info))) (loop for other-planet in +planets+ for cons = (or (assoc other-planet ret) (car (push (list other-planet) ret))) do (unless (eql planet other-planet) (cond ((find other-planet tatkalika-friends) (incf (getf (cdr cons) :tatkalika-friends 0)) (cond ((find other-planet friends)) ((find other-planet neutrals) (setq neutrals (delete other-planet neutrals)) (pushnew other-planet friends)) ((find other-planet enemies) (setq enemies (delete other-planet enemies)) (pushnew other-planet neutrals)) #+nil((find other-planet '(rahu ketu))) ((error "Sanity.")))) (t (incf (getf (cdr cons) :tatkalika-enemies 0)) (cond ((find other-planet enemies)) ((find other-planet neutrals) (setq neutrals (delete other-planet neutrals)) (pushnew other-planet friends)) ((find other-planet friends) (setq friends (delete other-planet friends)) (pushnew other-planet friends)) #+nil((find other-planet '(rahu ketu))) ((error "Sanity."))))))))) (values (mapcar (lambda (x) (sort x #'string< :key 'symbol-name)) (list friends neutrals enemies)) ret)))) ;;; ---------------------------------------------------------------------- ;;; ;;; ;;; (defun planets-in-exaltation (&optional (chart-info *chart-info*)) (remove-if-not (lambda (planet) (longitude-lies-in-range (longitude-of-planet planet chart-info) (get planet :exaltation-longitudes))) +planets+)) (defun planets-in-debilitation (&optional (chart-info *chart-info*)) (remove-if-not (lambda (planet) (longitude-lies-in-range (longitude-of-planet planet chart-info) (get planet :debilitation-longitudes))) +planets+)) (defun planets-in-moolatrikona-longitudes (&optional (chart-info *chart-info*)) (remove-if-not (lambda (planet) (some (lambda (range) (longitude-lies-in-range (longitude-of-planet planet chart-info) range)) (get planet :moolatrikona-longitudes-list))) +planets+)) (defun planets-in-own-longitudes (&optional (chart-info *chart-info*)) (remove-if-not (lambda (planet) (some (lambda (range) (longitude-lies-in-range (longitude-of-planet planet chart-info) range)) (get planet :own-longitudes-list))) +planets+)) ;; XXX the next three are redundant (defun planets-in-exaltation-sign (&optional (chart-info *chart-info*)) (remove-if-not (lambda (planet) (eq (sign-of-planet planet chart-info) (get planet :exaltation-sign))) +planets+)) (defun planets-in-debilitation-sign (&optional (chart-info *chart-info*)) (remove-if-not (lambda (planet) (eq (sign-of-planet planet chart-info) (get planet :debilitation-sign))) +planets+)) (defun planets-in-ruling-sign (&optional (chart-info *chart-info*)) (remove-if-not (lambda (planet) (eq (get (sign-of-planet planet chart-info) :ruler) planet)) +planets+)) (defun planets-in-detriment (&optional (chart-info *chart-info*)) (remove-if-not (lambda (planet) (let* ((sign (sign-of-planet planet chart-info)) (opposite-sign (opposite-sign-of sign))) (eq planet (get opposite-sign :ruler)))) +planets+)) (defun planets-in-friends-sign (&optional (chart-info *chart-info*)) (remove-if-not (lambda (planet) (find planet (first (compute-combined-relations planet chart-info)))) +planets+)) (defun planets-in-enemies-sign (&optional (chart-info *chart-info*)) (remove-if-not (lambda (planet) (find planet (third (compute-combined-relations planet chart-info)))) +planets+)) (defvar +planets-in-states+ '(planets-in-exaltation planets-in-debilitation planets-in-moolatrikona-longitudes planets-in-own-longitudes planets-in-exaltation-sign planets-in-debilitation-sign planets-in-ruling-sign planets-in-detriment planets-in-friends-sign planets-in-enemies-sign)) (defun planets-in-states (&optional (chart-info *chart-info*)) (loop for x in +planets-in-states+ for y = (funcall x chart-info) when y collect (list x y))) ;;; ---------------------------------------------------------------------- ;;; ;;; TRANSIT (ANNUAL) CHARTS ;;; (defun compose-transit-chart (chart1 chart2) "CHART2 is chart for NOW. Preserve house cusps of CHART1 and planet positions of CHART2. Return a new chart." (let* ((chart-data1 (chart-info-data chart1)) (chart-data2 (chart-info-data chart2)) (fortuna (assoc 'Fortuna chart-data1))) (setq chart-data2 (remove-if (lambda (x) (find (car x) '(Fortuna Ascendant))) chart-data2)) (make-chart-info (nconc (list fortuna) (remove-if (lambda (x) (symbolp (car x))) chart-data1) (remove-if (lambda (x) (numberp (car x))) chart-data2))))) ;;; ---------------------------------------------------------------------- ;;; ;;; ASPECTS (WESTERN) ;;; (defvar +kp-aspects+ ;; angle diagnostic strength applying-degrees separating-deg . names '((162 (slightly good) 16 0 0 |162|) (126 (unknown) 16 4 4 |126|) (54 (slightly good) 16 2 2 |54|) (108 (favourable) 15 2 2 tredecile) (36 (minor good) 15 2 2 decile semi-quintile) (24 (slightly good) 15 0 0 quincile quindecile) (18 (slightly good) 15 2 2 semi-decile vigintile) (30 (minor benefic) 15 2 2 semi-sextile) (45 (slightly adverse) 15 2 2 semi-square semi-quadrate) (72 (slightly good) 10 0 0 quintile) ;5th house results (60 (slightly good) 9 6 6 sextile) ;similar to trine (90 (adverse) 8 6 6 square quadrate quartile) (135 (slightly adverse) 7 2 2 sesquiquadrate) (144 (favourable) 6 3 3 biquintile) ;from cusp. as good as trine (150 (slightly adverse) 5 2 3 quincunx) ;6th house results (120 (strong benign) 4 6 6 trine) (180 (adverse) 3 8 8 opposition) (0 (mixed) 0 0 0 rapt-conjunction partile) (0 (weak) 1 6 8 platic-conjunction wide))) (defvar +kp-orbs-app/sep+ ;; body applying-degrees separating-deg (strength 2) '((Sun 12 17) (Moon 8 12))) (defvar *aspect-zero-fuzz* 0.2) (defvar *aspect-overriding-fuzz* nil) (defun %frob-app/sep-for-annual-chart (x y range) "FIXME. Give the orb a range of 5 deg for aspects among Sun and Moon and the aspects among the major planets should be 2 degrees. The conjunction, opposition, thr trine, etc. give only one degree. Other aspects are considered to be weak." (if (zerop range) range (if (or (and (eql x 'Sun) (eql y 'Moon)) (and (eql y 'Sun) (eql x 'Moon))) 2.5 (if (and (symbolp x) (symbolp y)) 1 0.5)))) (defun compute-all-aspects (&optional (chart-info *chart-info*) chart2 (aspect-zero-fuzz *aspect-zero-fuzz*) (aspect-overriding-fuzz *aspect-overriding-fuzz*)) "Return a list of ((PLANET1 PLANET2) DEGREES DIFFERENCE RELATIVE-STRENGTH NAME . DIAGNOSTICS). If CHART2 is supplied compute transits for the annual chart." (flet ((within-orb (zl zl2 app sep) (if aspect-overriding-fuzz (setq app aspect-overriding-fuzz sep aspect-overriding-fuzz) (if (and (zerop app) aspect-zero-fuzz) (setq app aspect-zero-fuzz) (if (and (zerop sep) aspect-zero-fuzz) (setq sep aspect-zero-fuzz)))) (zodiac-longitude-lies-in-range zl2 (mod (- zl app) 360) (mod (+ zl sep) 360))) (gzl (x chart-info) (convert-longitude-to-zodiac-longitude (etypecase x (symbol (longitude-of-planet x chart-info)) (number (longitude-of-cusp x chart-info))))) (delta (angle1 angle2) (let ((x (- angle1 angle2))) (/ (ftruncate (* 100 (* (signum x) (mod x 360)))) 100)))) (let* ((all-elems (nconc (unless (simple-chart-p chart-info) (loop for i from 1 to 12 collect i)) (mapcar #'car (slot-value chart-info 'planet-longitude-alist)))) (chart2-elems (when chart2 (mapcar #'car (slot-value chart-info 'planet-longitude-alist)))) (all-aspects (loop for i from 0 for x in all-elems for xl = (gzl x chart-info) nconc (loop for y in (if chart2 chart2-elems (nthcdr (1+ i) all-elems)) for yl = (gzl y (if chart2 chart2 chart-info)) for l = (list x y) unless (or (every (lambda (a) (or (numberp a) (find a '(Fortuna Ascendant)))) l) (every (lambda (a) (find a '(Rahu Ketu))) l) (some (lambda (a) (find a '(Ascendant))) l)) nconc (or (loop for (angle1 desc strength app sep . names) in +kp-aspects+ when chart2 ;FIXME do (setq app (%frob-app/sep-for-annual-chart x y app) sep (%frob-app/sep-for-annual-chart x y sep)) if (or (within-orb yl (mod (+ xl angle1) 360) app sep) (within-orb xl (mod (+ yl angle1) 360) app sep)) collect (list* (list x y) angle1 (delta xl yl) strength (car names) desc)) (loop for (body app sep) in +kp-orbs-app/sep+ when chart2 ;FIXME do (setq app (%frob-app/sep-for-annual-chart x y app) sep (%frob-app/sep-for-annual-chart x y sep)) if (or (and (eql x body) (within-orb xl yl app sep)) (and (eql y body) (within-orb yl xl app sep))) collect (list (list x y) 0 (delta xl yl) 2 'orb-conjunction))))))) (sort all-aspects #'< :key #'fourth)))) (defun print-all-aspects (&optional (chart-info *chart-info*) (stream *standard-output*) &aux chart2) ;; If the first argument is a list of 2 charts compute transits. (etypecase chart-info (chart-info) (list (setq chart2 (cadr chart-info) chart-info (car chart-info)))) (labels ((cmpname (p q) (if (and (numberp p) (numberp q)) (< p q) (string< (princ-to-string p) (princ-to-string q)))) (aspects-sorter-by-strength (a b) (< (fourth a) (fourth b))) (aspects-sorter-house-order-hack (a b) ;;XXX order by house number. assumes ((house planet)..) (if (and (numberp (caar a)) (numberp (caar b))) (< (caar a) (caar b)))) (aspects-sorter-by-type1 (a b) (> (count-if 'symbolp (car a)) (count-if 'symbolp (car b)))) (aspects-sorter-by-name (a b) (let ((x (car a)) (y (car b))) (or (cmpname (car x) (car y)) (and (not (cmpname (car x) (car y))) (cmpname (cadr x) (cadr y)))))) (make-ordering-form (tests) (if (endp (cdr tests)) `(funcall ',(car tests) a b) `(or (funcall ',(car tests) a b) (and (not (funcall ',(car tests) b a)) ,(make-ordering-form (cdr tests)))))) (make-sort-comparator (&rest comparator-function-names) (compile nil `(lambda (a b) ,(make-ordering-form comparator-function-names))))) (let ((all-aspects (compute-all-aspects chart-info chart2))) (when all-aspects (unless chart2 (map-into all-aspects (lambda (x) (destructuring-bind ((p q) . rest) x (declare (ignore rest)) (unless (cmpname p q) (rplaca x (list q p)))) x) all-aspects)) (setq all-aspects (sort all-aspects (make-sort-comparator #'aspects-sorter-by-type1 #'aspects-sorter-house-order-hack #'aspects-sorter-by-strength #'aspects-sorter-by-name))) (print-table (loop for ((p q) degrees delta strength name . descriptions) in all-aspects collect (list p q degrees strength name descriptions delta)) stream))))) ;;; ---------------------------------------------------------------------- ;;; ;;; RASI AND GRIHA DRISHTIS (HINDU ASPECTS) ;;; (defun compute-all-sign-drishtis (&optional (chart-info *chart-info*)) "Retruns a list of (PLANET1 PLANET2 TYPE) of planets aspecting each other in sign drishtis. Aries, Cancer, Libra, and Capricorn, the 1st quadrangle are Chara, Movable. 2nd quadrangle are Sthira or Fixed, the 3rd quadrangle are Dwichara or Dual rasis. A movable sign aspects all fixed signs except the one adjacent to it. Dual signs aspect other dual signs." (flet ((sign-type (sign) (ecase (1+ (mod (1- (get sign :number)) 3)) (1 :Movable) (2 :Fixed) (3 :Dual)))) (let ((all-sign-drishtis (loop for s on +signs+ for s1 = (car s) for n1 = (get s1 :number) for t1 = (sign-type s1) nconc (loop for s2 in (cdr s) for n2 = (get s2 :number) for t2 = (sign-type s2) do (assert (> n2 n1)) when (case t1 (:Dual (if (eql t2 :Dual) (list s1 s2 :Dual))) (otherwise (unless (or (= (- n2 n1) 1) (= (- n2 n1) 11)) (when (and (not (eql t2 :Dual)) (not (eql t2 t1))) (list s1 s2 :Movable-Fixed))))) collect it)))) (if (null chart-info) all-sign-drishtis (loop for x in all-sign-drishtis for (s1 s2 type) = x nconc (loop for p1 in (planets-in-sign s1 chart-info) nconc (loop for p2 in (planets-in-sign s2 chart-info) collect (list p1 p2 x)))))))) ;; house positions aspected by each planet (griha drishtis) (defvar +planetary-aspects+ '(((7 4 8) Mars) ((7 5 9) Jupiter Rahu Ketu) ((7 3 10) Saturn) ((7) Moon Venus Mercury Sun))) (defun compute-drishtis-for-planet (planet &optional (chart-info *chart-info*)) "Return a list of (HOUSE . PLANETS-ASPECTED)." (loop with positions-aspected = (car (rassoc planet +planetary-aspects+ :test #'member)) for i from 1 repeat 12 for house-number = (house-of-planet planet chart-info) then (house+ house-number 2) for type = (find i positions-aspected) for planets = (planets-in-house house-number chart-info) if (and type planets) collect (cons type planets))) (defun compute-all-planet-drishtis (&optional (chart-info *chart-info*)) "Returns a list of (PLANET1 PLANET2 . TYPES) of planets aspecting each other according to house positions." (let (ret) (mapcar (lambda (planet) (loop for (type . aspected-planets) in (compute-drishtis-for-planet planet chart-info) do (loop for other-planet in aspected-planets for entry = (find-if (lambda (x) (or (and (eql (car x) planet) (eql (cadr x) other-planet)) (and (eql (car x) other-planet) (eql (cadr x) planet)))) ret) when entry do (pushnew type (cddr entry)) else do (push (list planet other-planet type) ret)))) +planets+) ret)) (defun all-planet-drishtis (&optional (chart-info *chart-info*)) (caching-value (all-planet-drishtis :all-planet-drishtis chart-info) (compute-all-planet-drishtis chart-info))) ;;; ---------------------------------------------------------------------- ;;; ;;; KP LOOM GROUPING ;;; (defvar +kp-sign-groupings+ '((Feminine Taurus Cancer Virgo Scorpio Capricorn Pisces) ;Even (Masculine Aries Gemini Leo Libra Sagittarius Aquarius) ;Odd (Movable Aries Cancer Libra Capricorn) ;Chara (1 4 7 10) (Fixed Taurus Leo Scorpio Aquarius) ;Sthira (2 5 8 11) (Common Gemini Virgo Sagittarius Pisces) ;Dvichara (3 6 9 12) (Fruitful Cancer Scorpio Pisces) (Barren Gemini Leo Virgo) (Bicorporeal Gemini Sagittarius Pisces) (|Long Ascension| Cancer Leo Virgo Libra Sagittarius) (|Short Ascension| Aries Taurus Gemini Capricorn Aquarius Pisces) (Northern Aries Taurus Gemini Cancer Leo Virgo) (Southern Libra Scorpio Sagittarius Capricorn Aquarius Pisces) (Equinoctial Aries Libra) (Solsticial Cancer Capricorn) (Cardinal Aries Cancer Libra Capricorn) (Tropical Cancer Capricorn) (Fiery Aries Leo Sagittarius) ;Agni (1 5 9) (Earthy Taurus Virgo Capricorn) ;Bhu (2 6 10) (Watery Cancer Scorpio Pisces) ;Jala (4 8 12) (Airy Gemini Libra Aquarius) ;Vayu (3 7 11) )) (defvar +kp-planet-groupings+ '((Feminine Neptune Venus Moon) (Superior Pluto Neptune Uranus Saturn Jupiter Mars) (Masculine Uranus Saturn Jupiter Mars Sun) (Benefics Jupiter Venus |Waxing Moon| |Unafflicted Mercury|) (Malefics Sun Mars Saturn Uranus Neptune |Waning Moon| |Afflicted Mercury|))) (defvar +kp-house-groupings+ '((Angles 1 4 7 10) ;Kendras (Succedent 2 5 8 11) ;Panapara, Fixed (Cadent 3 6 9 12) ;Apoklima, (Weakened) (Upachaya 3 6 10 11) ;Favourable (Dushtana 6 8 12) ;Evil (Trikona 1 5 9) ;Trines )) (defvar +house-matters+ '((Health 1 6 8) (Income 2 11 10) (Children 5) (|Love affairs| 5 7) (spirituality 9 12) (Expenditure 12) ((Litigation Insurance) 8 12) (Siblings 3 11) ((Home Property) 4 8) (Education 5 9) ((Communications Letters) 3 11) ((Business Interview) 7) ((service |working for others|) 6) ((fame profession) 10) (spouse 7) ((family wealth) 2) ((pets animals) 5 Venus) ((Mystery Intrigue) 8 Rahu Ketu)))