home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / educatin / csa.arc / CSA.LSP < prev    next >
Lisp/Scheme  |  1987-05-21  |  34KB  |  783 lines
  1. ;************************************************************************
  2. ;*                                                                      *
  3. ;*  program :   CSA                                                     *
  4. ;*  author  :   Chris Lord                                              *
  5. ;*  version :   3.17 (5/21/87)                                          *
  6. ;*  date    :   February 18, 1987                                       *
  7. ;*                                                                      *
  8. ;*  Copyright (c) 1987 by Chris Lord                                    *
  9. ;*                                                                      *
  10. ;*  This program was written for a course in logic and lisp at FSC      *
  11. ;*  as a learning experience.  Having served its purpose, the author    *
  12. ;*  contributes this code to the public domain so that others may also  *
  13. ;*  learn.  I would be interested in any suggestions/improvements/bugs  *
  14. ;*  anyone finds.  Please address all comments to:                      *
  15. ;*                                                                      *
  16. ;*                                      Chris Lord                      *
  17. ;*                                      38 Main Street                  *
  18. ;*                                      Princeton, MA 01541             *
  19. ;*                                      DEC ENET RAINBO::LORD           *
  20. ;*                                                                      *
  21. ;************************************************************************
  22.  
  23. ;************************************************************************
  24. ;*                                                                      *
  25. ;*  program description                                                 *
  26. ;*                                                                      *
  27. ;*  This program is the first step in determining the validity of       *
  28. ;*  standard (and some non-standard) categorical syllogisms.  The       *
  29. ;*  the validity of a syllogism is based on a collection of eight       *
  30. ;*  rules, seven of which are implemented in this version.  See the     *
  31. ;*  accompanying manual for a completed description as well as a        *
  32. ;*  short tutorial in syllogism logic.                                  *
  33. ;*                                                                      *
  34. ;*  edit history                                                        *
  35. ;*                                                                      *
  36. ;*  3.15  add check for same premisses in main routine CSA to catch     *
  37. ;*        some other bad syllogism (ccl 5/13/87)                        *
  38. ;*  3.16  add further syllogism checks in function CSA (ccl 5/14/87)    *
  39. ;*  3.17  add heuristic for dealing with subjects that are single       *
  40. ;*        atoms to format_prop (ccl 5/21/87)                            *
  41. ;*  3.18  add list of atoms to strip from props when parsing such as    *
  42. ;*        (the an a) (not yet)                                          *
  43. ;*                                                                      *
  44. ;************************************************************************
  45.  
  46.  
  47. ;************************************************************************
  48. ;*                                                                      *
  49. ;*  data declarations                                                   *
  50. ;*                                                                      *
  51. ;*  these are global symbols that are currently used by only single     *
  52. ;*  functions -- this is likely to change.                              *
  53. ;*                                                                      *
  54. ;************************************************************************
  55.  
  56. ;+
  57. ;   this is the set of univeral-affirmative quantifiers that may appear
  58. ;   in the proposition.  Any member is replaced with the standard
  59. ;   quantifier ALL
  60. ;-
  61.  
  62. (setq universal_affirm '(all every any everything anything everyone
  63.                          anyone whoever whoso who whatever a an the))
  64.  
  65. ;+
  66. ;   this is the set of univeral-negative quantifiers that may appear
  67. ;   in the proposition.  Any member is replaced with the standard
  68. ;   quantifier NO
  69. ;-
  70.  
  71. (setq universal_neg '(no none nothing no-one))
  72.  
  73. ;+
  74. ;   this is the set of particular quantifiers (quality is determined
  75. ;   by the verb adjunct 'not') that may appear in the propostion.
  76. ;   Any member is replaced with the standard quantifier SOME
  77. ;-
  78.  
  79. (setq particular_quantifiers '(some most many few))
  80.  
  81. ;+
  82. ;   this is the set of words that precede a form of the verb 'to be'
  83. ;   an indicate (generally) that it is not the verb of the proposition
  84. ;   as in: all men who are green are frogs
  85. ;-
  86.  
  87. (setq non_verb_preds '(who whom that))
  88.  
  89. ;+
  90. ;   this is the error code table, each error has a code followed
  91. ;   by the actual error text
  92. ;-
  93.  
  94. (setq error_codes '(badprop "bad proposition encountered"
  95.                     badquan "bad quantifier encountered"
  96.                     badsubj "bad subject encountered"
  97.                     badverb "bad verb encountered"
  98.                     badpred "bad predicate encountered"
  99.                     badform "bad form encountered"
  100.                     badsyll "bad syllogism encountered"))
  101.  
  102. ;************************************************************************
  103. ;*                                                                      *
  104. ;*  rule base                                                           *
  105. ;*                                                                      *
  106. ;*  the following functions are each responsible for checking a given   *
  107. ;*  form against one of the rules for valid functions.  Rules return    *
  108. ;*  nil if they pass, something else otherwise.  Every rule is passed   *
  109. ;*  the form of the syllogism in (n x x x) form.                        *
  110. ;*                                                                      *
  111. ;************************************************************************
  112.  
  113. ;+
  114. ; the following are inherent characteristics of each type of syllogism
  115. ; used in creating the rules:
  116. ;
  117. ; type       quantity         quality       S   P
  118. ; ----      ----------      -----------    --- ---
  119. ;   A       universal       affirmative     D   U
  120. ;   E       universal       negative        D   D
  121. ;   I       particular      affirmative     U   U
  122. ;   O       particular      negative        U   D
  123. ;
  124. ;   where: U is undistributed   S is subject
  125. ;          D is distributed     P is predicate
  126. ;-
  127.  
  128. ;+
  129. ;   Rule  1: A categorical syllogism must contain three and only
  130. ;   three terms or it commits the fallacy of four terms.  
  131. ;
  132. ;   this rule cannot be implemented without an extensive knowledge of
  133. ;   english vocabulary.  It is in this rule that ambiguous class
  134. ;   descriptors and the misuse of synonyms are caught.  Often times
  135. ;   this rule is also used to catch syllogisms with no middle term.
  136. ;-
  137.  
  138. (defun rule_1 (form)
  139.     nil)
  140.  
  141. ;+
  142. ;   Rule  2:  The  middle term must be distributed at least once
  143. ;   or it commits the fallacy of undistributed middle.  
  144. ;-
  145.    
  146. (defun rule_2 (form)
  147.     (setq p1 (cadr form))   ; type of prop 1
  148.     (setq p2 (caddr form))  ; type of prop 2
  149.     (not (case (car form)
  150.         (1  (or (member p1 '(A E)) (member p2 '(E O))))
  151.         (2  (or (member p1 '(E O)) (member p2 '(E O))))
  152.         (3  (or (member p1 '(A E)) (member p2 '(A E))))
  153.         (4  (or (member p1 '(E O)) (member p2 '(A E)))))))
  154.  
  155. ;+
  156. ;   Rule  3:  No term may be distributed in the conclusion which
  157. ;   is  undistributed in the premisses or it commits the fallacy
  158. ;   of illicit major or minor.  
  159. ;
  160. ;   this rule is in two parts.  Part A checks for illicit major;
  161. ;   part B checks for illicit minor.
  162. ;-
  163.  
  164. (defun rule_3A (form)
  165.     (setq p1 (cadr form))   ; type of prop 1
  166.     (setq p2 (caddr form))  ; type of prop 2
  167.     (and
  168.     (member (cadddr form) '(E O))
  169.     (case (car form)
  170.         (1  (member p1 '(A I)))
  171.         (2  (member p1 '(I O)))
  172.         (3  (member p1 '(A I)))
  173.         (4  (member p1 '(I O))))))
  174.  
  175. (defun rule_3B (form)
  176.     (setq p1 (cadr form))   ; type of prop 1
  177.     (setq p2 (caddr form))  ; type of prop 2
  178.     (and
  179.     (member (cadddr form) '(A E))
  180.     (case (car form)
  181.         (1  (member p1 '(I O)))
  182.         (2  (member p1 '(I O)))
  183.         (3  (member p1 '(A I)))
  184.         (4  (member p1 '(A I))))))
  185.  
  186. ;+
  187. ;   Rule  4:  No  categorical  syllogism  can  have two negative
  188. ;   premisses   or   it   commits   the   fallacy  of  exclusive
  189. ;   premisses.  
  190. ;-
  191.  
  192. (defun rule_4 (form)
  193.     (setq p1 (cadr form))   ; type of prop 1
  194.     (setq p2 (caddr form))  ; type of prop 2
  195.     (and (member p1 '(E O)) (member p2 '(E O))))
  196.  
  197. ;+
  198. ;   Rule  5:  If either premiss if negative, the conclusion must
  199. ;   be  negative  or  it  commits  the  fallacy  of  drawing  an
  200. ;   affirmative conclusion from a negative premiss.  
  201. ;-
  202.  
  203. (defun rule_5 (form)
  204.     (setq p1 (cadr form))   ; type of prop 1
  205.     (setq p2 (caddr form))  ; type of prop 2
  206.     (and (or (member p1 '(E O)) (member p2 '(E O)))
  207.     (member (cadddr form) '(A I))))
  208.  
  209. ;+
  210. ;   Rule  6:  A  categorical  proposition  must have at least on
  211. ;   universal   premiss   or  it  commits  the  fallacy  of  two
  212. ;   particulars.  
  213. ;-
  214.  
  215. (defun rule_6 (form)
  216.     (setq p1 (cadr form))   ; type of prop 1
  217.     (setq p2 (caddr form))  ; type of prop 2
  218.     (and (member p1 '(I O)) (member p2 '(I O))))
  219.  
  220. ;+
  221. ;   Rule  7:  If  one premiss is particular, the conclusion must
  222. ;   be  particular  or  it  commits  the  fallacy  of  drawing a
  223. ;   universal conclusion from a particular premiss.  
  224. ;-
  225.  
  226. (defun rule_7 (form)
  227.     (setq p1 (cadr form))   ; type of prop 1
  228.     (setq p2 (caddr form))  ; type of prop 2
  229.     (and (or (member p1 '(I O)) (member p2 '(I O)))
  230.     (member (cadddr form) '(A E))))
  231.  
  232. ;+
  233. ;   Rule  8:  (existential  interpretation  only)  A  particular
  234. ;   conclusion   cannot  have  two  universal  premisses  or  it
  235. ;   commits the existential fallacy.  
  236. ;-
  237.  
  238. (defun rule_8 (form)
  239.     (setq p1 (cadr form))   ; type of prop 1
  240.     (setq p2 (caddr form))  ; type of prop 2
  241.     (and (and (member p1 '(A E)) (member p2 '(A E)))
  242.     (member (cadddr form) '(I O))))
  243.  
  244. (defun rule_check (form)
  245.     (cond
  246.         ((rule_2 form)
  247.          (princ "this syllogism commits the fallacy")
  248.          (princ " of an undistributed middle term"))
  249.         ((rule_3A form)
  250.          (princ "this syllogism commits the fallacy")
  251.          (princ " of illicit major"))
  252.         ((rule_3B form)
  253.          (princ "this syllogism commits the fallacy")
  254.          (princ " of illicit minor"))
  255.         ((rule_4 form)
  256.          (princ "this syllogism commits the fallacy")
  257.          (princ " of exclusive premisses"))
  258.         ((rule_5 form)
  259.          (princ "this syllogism commits the fallacy")
  260.          (princ " of drawing an") (terpri)
  261.          (princ "affirmative conclusion from a negative premiss"))
  262.         ((rule_6 form)
  263.          (princ "this syllogism commits the fallacy")
  264.          (princ " of two particulars"))
  265.         ((rule_7 form)
  266.          (princ "this syllogism commits the fallacy")
  267.          (princ " of drawing a universal") (terpri)
  268.          (princ "conclusion from a particular premiss"))
  269.         ((rule_8 form)
  270.          (princ "this syllogism commits the existential")
  271.          (princ " fallacy under boolean interpretation") (terpri)
  272.          (princ "under aristotelean interpretation, this syllogism is valid"))
  273.         (T (princ "this is a valid syllogism under both boolean") (terpri)
  274.            (princ "and aristotelean interpretation"))))
  275.  
  276.  
  277. ;************************************************************************
  278. ;*                                                                      *
  279. ;*  error reporter                                                      *
  280. ;*                                                                      *
  281. ;*  this function isolates our error-trapping (without binding the      *
  282. ;*  code to XLISP specific features).  It uses the error_code list.     *
  283. ;*  Any call to this must include the error code, function/routine,     *
  284. ;*  and the offending expression.  This function does not return!       *
  285. ;*                                                                      *
  286. ;************************************************************************
  287.  
  288. (defun error (code operation expr)
  289.     (princ "error: ")
  290.     (princ (cadr (member code error_codes)))
  291.     (terpri)
  292.     (princ "       ")
  293.     (princ operation)
  294.     (terpri)
  295.     (princ "       in ")
  296.     (print expr)
  297.     (terpri)
  298.     (top-level))
  299.  
  300.  
  301. ;************************************************************************
  302. ;*                                                                      *
  303. ;*  toolbox functions                                                   *
  304. ;*                                                                      *
  305. ;*  the following are a collection of very short utility functions.     *
  306. ;*  In most cases, they serve to isolate the main functions from the    *
  307. ;*  actual data structures used.  In others, they provide useful        *
  308. ;*  functions that may be shared (some are currently only used by       *
  309. ;*  single functions).                                                  *
  310. ;*                                                                      *
  311. ;************************************************************************
  312.  
  313. ;+
  314. ;   these four functions return various components of a formatted
  315. ;   proposition: quantifier, subject, verb, predicate.  Here we
  316. ;   also do some checking and return an appropriate error if we
  317. ;   can't get the needed component
  318. ;-
  319.  
  320. (defun quantifier (prop)        ; returns quantifier as atom
  321.     (cond
  322.         ((caar prop))
  323.         ((error 'badquan "while fetching quantifier" prop))))
  324.  
  325. (defun subject (prop)           ; returns subject as list
  326.     (cond
  327.         ((cadr prop))
  328.         ((error 'badsubj "while fetching subject" prop))))
  329.  
  330. (defun verb_copula (prop)       ; returns verb as list
  331.     (cond
  332.         ((caddr prop))
  333.         ((error 'badverb "while fetching verb" prop))))
  334.  
  335. (defun predicate (prop)         ; returns predicate as list
  336.     (cond
  337.         ((cadddr prop))
  338.         ((error 'badpred "while fetching predicate" prop))))
  339.  
  340. ;+
  341. ;   these three functions return the terms of a syllogism.
  342. ;   Note: the syllogism mus be formatted (major,minor,conc form)
  343. ;-
  344.  
  345. (defun major_term (syl)
  346.     (predicate (caddr syl)))
  347.  
  348. (defun minor_term (syl)
  349.     (subject (caddr syl)))
  350.     
  351. (defun middle_term (syl)
  352.     (cond
  353.         ((equal (predicate (car syl)) (major_term syl)) (subject (car syl)))
  354.         (T (predicate (car syl)))))
  355. ;+
  356. ;   function converts anything that looks like a verb form of 'to be'
  357. ;   into either 'are' or 'are not'.  This is for analysis in the
  358. ;   proposition formatter.
  359. ;-
  360.  
  361.  
  362. (defun is_to_are (prop)
  363.     (cond
  364.         ((null prop) nil)
  365.         ((eq (car prop) 'is) (cons 'are (is_to_are (cdr prop))))
  366.         ((eq (car prop) 'was) (cons 'are (is_to_are (cdr prop))))
  367.         ((eq (car prop) 'were) (cons 'are (is_to_are (cdr prop))))
  368.         ((eq (car prop) 'wasnt) (append '(are not) (is_to_are (cdr prop))))
  369.         ((eq (car prop) 'werent) (append '(are not) (is_to_are (cdr prop))))
  370.         ((eq (car prop) 'isnt) (append '(are not) (is_to_are (cdr prop))))
  371.         ((eq (car prop) 'arent) (append '(are not) (is_to_are (cdr prop))))
  372.         (T (cons (car prop) (is_to_are (cdr prop))))))
  373.  
  374. ;+
  375. ;   simple function to count the number of are's in the passed
  376. ;   proposition (unformatted).
  377. ;-
  378.  
  379. (defun count_are (prop)
  380.     (cond
  381.         ((null prop) 0)
  382.         ((eq (car prop) 'are) (1+ (count_are (cdr prop))))
  383.         (T (count_are (cdr prop)))))
  384.  
  385. ;+
  386. ;   simple function to return leftmost len s-exprs in a list
  387. ;-
  388.  
  389. (defun left (prop len)
  390.     (cond
  391.         ((= len 0) nil)
  392.         (T (cons (car prop) (left (cdr prop) (1- len))))))
  393.  
  394. ;+
  395. ;   simple function to return rightmost len s-exprs in a list
  396. ;-
  397.  
  398. (defun right (prop len)
  399.     (reverse (left (reverse prop) len)))
  400.  
  401.  
  402. ;************************************************************************
  403. ;*                                                                      *
  404. ;*  proposition formatter                                               *
  405. ;*                                                                      *
  406. ;*  function accepts a prop in (quantifier subject verb predicate)      *
  407. ;*  form where parts are not necessarily atoms as in (all men that are  *
  408. ;*  green are jealous men).  Returns the same prop broken into lists    *
  409. ;*  that represent the various components as in ((quantifier) (subject) *
  410. ;*  (verb) (predicate)).                                                *
  411. ;*                                                                      *
  412. ;************************************************************************
  413.  
  414.  
  415. (defun format_prop (prop)
  416.  
  417. ;+
  418. ;   fist step is to convert all forms of the verb 'to be' into something
  419. ;   common -- are.  Proposition is then broken into predicate and
  420. ;   subject based on the number of are's in it
  421. ;-
  422.  
  423.     (setq old_prop (is_to_are prop))    ; old_prop use to be prop (unedited)
  424.     (setq temp_prop old_prop)           ; this has been added for debugging
  425.     (case (count_are temp_prop)
  426.  
  427. ;+
  428. ;   if there are 0 or 4 are's then we have an invalid proposition
  429. ;-
  430.  
  431.           (0 (error 'badprop "while trying to format" prop))
  432.           (4 (error 'badprop "while trying to format" prop))
  433. ;+
  434. ;   if there is one are, then it is most likely the verb of the
  435. ;   proposition
  436. ;-
  437.  
  438.           (1 (setq temp_subject
  439.              (reverse (cdr (member 'are (reverse temp_prop)))))
  440.              (setq temp_predicate (cdr (member 'are temp_prop))))
  441.  
  442. ;+
  443. ;   new routine to format for two are's -- this is the most difficult
  444. ;   case.  This uses the presence of certain key words before one
  445. ;   of the ares (that who whom) to identify the one that is NOT the
  446. ;   verb.  This will work in the majority cases and definitely more
  447. ;   often than the old routine which was based on placement.
  448. ;-
  449.  
  450.            (2 (cond
  451.              ((member (cadr (member 'are (reverse temp_prop))) non_verb_preds)
  452.               (setq temp_subject (reverse (cdr (member 'are (cdr (member 'are (reverse temp_prop)))))))
  453.               (setq temp_predicate (cdr (member 'are temp_prop))))
  454.  
  455.              ((member (cadr (member 'are (cdr (member 'are (reverse temp_prop))))) non_verb_preds)
  456.               (setq temp_subject (reverse (cdr (member 'are (reverse temp_prop)))))
  457.               (setq temp_predicate (cdr (member 'are (cdr (member 'are temp_prop))))))
  458.  
  459.              (T (error 'badverb "while determining verb copula" old_prop))
  460.            ))
  461.  
  462. ;+
  463. ;   old routine to handle presence of two are's
  464. ;
  465. ;          (2 (cond
  466. ;                ((<= (length (member 'are (cdr (member 'are (cdr temp_prop)))))
  467. ;                ((<= (length (cdr (member 'are (cdr (member 'are (cdr temp_prop))))))
  468. ;                     (- (length (cdr temp_prop))
  469. ;                       (length (member 'are (cdr temp_prop)))))
  470. ;                    (setq temp_subject
  471. ;                          (left old_prop
  472. ;                                (length (cdr (member 'are
  473. ;                                (reverse temp_prop))))))
  474. ;                    (setq temp_predicate
  475. ;                          (cdr (member 'are (cdr (member 'are temp_prop))))))
  476. ;                (T (setq temp_subject
  477. ;                         (left old_prop (length (cdr (member 'are
  478. ;                         (cdr (member 'are (reverse temp_prop))))))))
  479. ;                   (setq temp_predicate
  480. ;                         (right old_prop (length (cdr (member 'are temp_prop))))))))
  481. ;-
  482.  
  483. ;+
  484. ;   if there are three are's in the temp prop, then the verb is
  485. ;   most likely the middle one
  486. ;-
  487.  
  488.           (3  (setq temp_subject
  489.                     (left old_prop (length (cdr (member 'are
  490.                     (cdr (member 'are (reverse temp_prop))))))))
  491.               (setq temp_predicate
  492.                     (right old_prop (length (cdr (member 'are
  493.                     (cdr (member 'are temp_prop)))))))))
  494.  
  495.     (setq temp_verb (last (left old_prop (1+ (length temp_subject)))))
  496.     (cond
  497.         ( (eq (car temp_predicate) 'not)
  498.           (setq temp_verb (append temp_verb '(not)))
  499.           (setq temp_predicate (cdr temp_predicate))))
  500. ; (ccl 5/21/87 3.17)
  501.     (cond
  502.         ((equal (length temp_subject) 1)
  503.          (setq temp_quantifier '(all)))
  504.         (T
  505.          (setq temp_quantifier (list (car temp_subject)))
  506.          (setq temp_subject (cdr temp_subject))))
  507.     (list temp_quantifier temp_subject temp_verb temp_predicate))
  508.  
  509.  
  510. ;************************************************************************
  511. ;*                                                                      *
  512. ;*  proposition evaluator                                               *
  513. ;*                                                                      *
  514. ;*  simply returns the type of the passed propositon.  Works on the     *
  515. ;*  assumption that quantifier in (all no some) and verb in (is, are,   *
  516. ;*  is not, are not).                                                   *
  517. ;*                                                                      *
  518. ;************************************************************************
  519.  
  520. (defun eval_prop (prop)
  521.     (case (quantifier prop)
  522.         ('all  'a)
  523.         ('no   'e)
  524.         ('some (if (= (length (verb_copula prop)) 2) 'o 'i))))
  525.  
  526.  
  527. ;************************************************************************
  528. ;*                                                                      *
  529. ;*  propositon filter                                                   *
  530. ;*                                                                      *
  531. ;*  function filters non-standard terms from the proposition.           *
  532. ;*  Presently, only handle easy non-standard quantifers, but in the     *
  533. ;*  future, will likely allow the filtering of synonyms, antonyms and   *
  534. ;*  plural forms to common terms.                                       *
  535. ;*                                                                      *
  536. ;************************************************************************
  537.  
  538. (defun filter_prop (prop)
  539.     (cond
  540.         ((member (quantifier prop) universal_affirm)
  541.          (cons (list (car universal_affirm)) (cdr prop)))
  542.         ((member (quantifier prop) universal_neg)
  543.          (cons (list (car universal_neg)) (cdr prop)))
  544.         ((member (quantifier prop) particular_quantifiers)
  545.          (cons (list (car particular_quantifiers)) (cdr prop)))
  546.         ((error 'badquan "while filtering quantifiers" prop))))
  547.  
  548.  
  549. ;************************************************************************
  550. ;*                                                                      *
  551. ;*  syllogism reader                                                    *
  552. ;*                                                                      *
  553. ;*  Reads the syllogism from stdin in premiss, premiss, conclusion      *
  554. ;*  order; returns all propositions in a list.                          *
  555. ;*                                                                      *
  556. ;************************************************************************
  557.  
  558. (defun read_syl ()
  559.     (princ "enter a premiss ")
  560.     (setq temp_prop1 (read))
  561.     (princ "enter a premiss ")
  562.     (setq temp_prop2 (read))
  563.     (princ "enter conclusion")
  564.     (setq temp_conc (read))
  565.     (list temp_prop1 temp_prop2 temp_conc))
  566.  
  567.  
  568. ;************************************************************************
  569. ;*                                                                      *
  570. ;*  syllogism formatter                                                 *
  571. ;*                                                                      *
  572. ;*  The syllogism formatter takes as input a complete syllogism in      *
  573. ;*  which the conclusion is last and the premisses are in either order. *
  574. ;*  It returns the syllogism with the major premiss first followed      *
  575. ;*  by the minor premiss and the conclusion.                            *  
  576. ;*                                                                      *
  577. ;************************************************************************
  578.  
  579. ;+
  580. ;   conclusion does the main work of format_syl
  581. ;-
  582.  
  583. (defun conclusion (prop1 prop2 prop3)
  584.     (cond
  585.         ((and
  586.             (or (equal (predicate prop1) (subject prop2))
  587.                 (equal (predicate prop1) (subject prop3))
  588.                 (equal (predicate prop1) (predicate prop2))
  589.                 (equal (predicate prop1) (predicate prop3)))
  590.             (or (equal (subject prop1) (subject prop2))
  591.                 (equal (subject prop1) (subject prop3))
  592.                 (equal (subject prop1) (predicate prop2))
  593.                 (equal (subject prop1) (predicate prop3))))
  594.          (list (cond
  595.                     ((equal (predicate prop1) (subject prop2)) prop2)
  596.                     ((equal (predicate prop1) (subject prop3)) prop3)
  597.                     ((equal (predicate prop1) (predicate prop2)) prop2)
  598.                     ((equal (predicate prop1) (predicate prop3)) prop3)
  599.                     ((error 'badprop "while finding major premiss"
  600.                     prop1)))
  601.                (cond
  602.                     ((equal (subject prop1) (subject prop2)) prop2)
  603.                     ((equal (subject prop1) (subject prop3)) prop3)
  604.                     ((equal (subject prop1) (predicate prop2)) prop2)
  605.                     ((equal (subject prop1) (predicate prop3)) prop3)
  606.                     ((error 'badprop "while finding minor premiss" prop1)))
  607.                prop1))
  608.         (T nil)))
  609.  
  610. ;+
  611. ;   format_syl was more adventurous at first, until it was discovered
  612. ;   it was not possible to determine the premisses and conclusion
  613. ;   given the props in any order, hence the breaking of of the fns
  614. ;-
  615.  
  616. (defun format_syl (syl)
  617.     (cond
  618.         ((conclusion (caddr syl) (car syl) (cadr syl)))
  619. ;        ((conclusion (car syl) (cadr syl) (caddr syl)))
  620. ;        ((conclusion (cadr syl) (caddr syl) (car syl)))
  621.         ((error 'badsyll "while determining major/minor premisses"
  622.                 (caddr syl)))))
  623.  
  624.  
  625.  
  626. ;************************************************************************
  627. ;*                                                                      *
  628. ;*  syllogism form                                                      *
  629. ;*                                                                      *
  630. ;*  this function determines the form of the syllogism based on the     *
  631. ;*  position of the middle term in the premisses and the type of each   *
  632. ;*  proposition.                                                        *
  633. ;*                                                                      *
  634. ;************************************************************************
  635.  
  636. (defun form (syl)
  637.     (cons 
  638.         (cond
  639.             ( (and (equal (middle_term syl) (subject (car syl)))
  640.                    (equal (middle_term syl) (predicate (cadr syl)))) '1)
  641.             ( (and (equal (middle_term syl) (predicate (car syl)))
  642.                    (equal (middle_term syl) (predicate (cadr syl)))) '2)
  643.             ( (and (equal (middle_term syl) (subject (car syl)))
  644.                    (equal (middle_term syl) (subject (cadr syl)))) '3)
  645.             ( (and (equal (middle_term syl) (predicate (car syl)))
  646.                    (equal (middle_term syl) (subject (cadr syl)))) '4)
  647.             ((error 'badform "while finding figure" syl)))
  648.         (list (eval_prop (car syllogism))
  649.               (eval_prop (cadr syllogism))
  650.               (eval_prop (caddr syllogism)))))
  651.  
  652.  
  653. ;************************************************************************
  654. ;*                                                                      *
  655. ;*  csa (main)                                                          *
  656. ;*                                                                      *
  657. ;*  this is the main function; it reads the syllogism, parses it and    *
  658. ;*  returns the results.  Note that some of the information (such as    *
  659. ;*  how it was parsed) was left here for my use, it is not necessary    *
  660. ;*  for the casual user.                                                *
  661. ;*                                                                      *
  662. ;************************************************************************
  663.  
  664. (defun csa ()
  665.     (setq temp_syl (read_syl))
  666.     (setq syllogism (format_syl (list
  667.         (filter_prop (format_prop (car temp_syl)))
  668.         (filter_prop (format_prop (cadr temp_syl)))
  669.         (filter_prop (format_prop (caddr temp_syl))))))
  670.  
  671. ; (ccl 5/13/87 3.15)
  672. ; (ccl 5/14/87 3.16)
  673.  
  674.      (if (or (equal (car syllogism) (cadr syllogism))
  675.              (equal (car syllogism) (caddr syllogism))
  676.              (equal (cadr syllogism) (caddr syllogism)))
  677.         (error 'badsyll "after formatting major/minor premisses"
  678.                 (caddr syllogism)))
  679.  
  680.     (terpri)
  681.     (princ "major premiss: ") (print (car syllogism))
  682.     (princ "minor premiss: ") (print (cadr syllogism))
  683.     (princ "conclusion:    ") (print (caddr syllogism))
  684.     (terpri)
  685.     (princ "major term:  ") (print (major_term syllogism))
  686.     (princ "minor term:  ") (print (minor_term syllogism))
  687.     (princ "middle term: ") (print (middle_term syllogism))
  688.     (terpri)
  689.     (setq syl_form (form syllogism))
  690.     (princ "mood:   ") (print (cdr syl_form))
  691.     (princ "figure: ") (print (car syl_form))
  692.     (terpri)
  693.     (rule_check syl_form)
  694.     (terpri)
  695.     (terpri))
  696.  
  697.  
  698. ;************************************************************************
  699. ;*                                                                      *
  700. ;*  csa test                                                            *
  701. ;*                                                                      *
  702. ;*  this function accepts a syllogism ( (prop) (prop) (conc) ) and      *
  703. ;*  procedes like function csa, used mostly as a debug routine to test  *
  704. ;*  a set of test syllogisms.                                           *
  705. ;*                                                                      *
  706. ;************************************************************************
  707.  
  708. (defun csa_test (temp_syl)
  709.     (princ "testing the following proposition:") (terpri) (terpri)
  710.     (princ "premiss 1:  ") (print (car temp_syl))
  711.     (princ "premiss 2:  ") (print (cadr temp_syl))
  712.     (princ "conclusion: ") (print (caddr temp_syl)) (terpri)
  713.     (setq syllogism (format_syl (list
  714.         (filter_prop (format_prop (car temp_syl)))
  715.         (filter_prop (format_prop (cadr temp_syl)))
  716.         (filter_prop (format_prop (caddr temp_syl))))))
  717.  
  718. ; (ccl 5/13/87 3.15)
  719. ; (ccl 5/14/87 3.16)
  720.  
  721.      (if (or (equal (car syllogism) (cadr syllogism))
  722.              (equal (car syllogism) (caddr syllogism))
  723.              (equal (cadr syllogism) (caddr syllogism)))
  724.         (error 'badsyll "after formatting major/minor premisses"
  725.                 (caddr syllogism)))
  726.  
  727.     (princ "major premiss: ") (print (car syllogism))
  728.     (princ "minor premiss: ") (print (cadr syllogism))
  729.     (princ "conclusion:    ") (print (caddr syllogism))
  730.     (terpri)
  731.     (princ "major term:  ") (print (major_term syllogism))
  732.     (princ "minor term:  ") (print (minor_term syllogism))
  733.     (princ "middle term: ") (print (middle_term syllogism))
  734.     (terpri)
  735.     (setq syl_form (form syllogism))
  736.     (princ "mood:   ") (print (cdr syl_form))
  737.     (princ "figure: ") (print (car syl_form))
  738.     (terpri)
  739.     (rule_check syl_form)
  740.     (terpri)
  741.     (terpri))
  742.  
  743.  
  744. ;************************************************************************
  745. ;*                                                                      *
  746. ;*  rule test and verify                                                *
  747. ;*                                                                      *
  748. ;*  these functions check the validity of all possible (256) standard   *
  749. ;*  form categorical syllogisms.  It is assumed the file CSA_GEN.LSP    *
  750. ;*  has been created by CSA_GEN.COM; output will go to stdout and       *
  751. ;*  CSA_GEN.TXT for verification by a logical human beastie.            *
  752. ;*                                                                      *
  753. ;************************************************************************
  754.  
  755. (defun rule_test (form)
  756.     (princ "form: ")
  757.     (print form)
  758.     (rule_check form)
  759.     (terpri)
  760.     (princ "----------------------------------------------")
  761.     (terpri))
  762.  
  763. (defun rule_verify ()
  764.     (princ "generating a list of validity checks for all 256") (terpri)
  765.     (princ "possible syllogism forms as stored in csa_gen.lsp") (terpri)
  766.     (princ "output will be in csa_gen.txtas well as here") (terpri)
  767.     (terpri)
  768.     (transcript "csa_gen.txt")
  769.     (load 'csa_gen.lsp)
  770.     (transcript))
  771.  
  772. ;************************************************************************
  773. ;*                                                                      *
  774. ;*                                                                      *
  775. ;************************************************************************
  776.  
  777. (terpri)
  778. (princ "Catagorical Syllogism Analyzer") (terpri)
  779. (princ "Version 3.17      May 21, 1987") (terpri)
  780. (princ "(c) Copyright 1987, Chris Lord") (terpri) (terpri)
  781. (top-level)
  782.  
  783.