wxsys-25.txt

一套美国国家宇航局人工智能中心NASA的专家系统工具源代码

  (printout t "    (9)  west" crlf)
  (printout t "    (10) northwest" crlf)
  (printout t ">")
  (bind ?answer (read))
  (while (not (member ?answer ?allowed-values)) do
    (printout t "Please confine your answer to one of the above choices." crlf)
    (printout t ">")
    (bind ?answer (read)))
  (if (eq ?answer 1) then (modify ?f (primary-clouds-moving-from not-applicable)))
  (if (eq ?answer 2) then (modify ?f (primary-clouds-moving-from unknown)))
  (if (eq ?answer 3) then (modify ?f (primary-clouds-moving-from north)))
  (if (eq ?answer 4) then (modify ?f (primary-clouds-moving-from northeast)))
  (if (eq ?answer 5) then (modify ?f (primary-clouds-moving-from east)))
  (if (eq ?answer 6) then (modify ?f (primary-clouds-moving-from southeast)))
  (if (eq ?answer 7) then (modify ?f (primary-clouds-moving-from south)))
  (if (eq ?answer 8) then (modify ?f (primary-clouds-moving-from southwest)))
  (if (eq ?answer 9) then (modify ?f (primary-clouds-moving-from west)))
  (if (eq ?answer 10) then (modify ?f (primary-clouds-moving-from northwest)))) 
  
;**********
;Rule to prompt user for the earlier cloud cover percentage.
;**********

(defrule ask-earlier-cloud-cover
  (declare (salience 1))
  ?f <- (old-data-from-user (cloud-cover unasked))
  =>
  (bind ?allowed-values (create$ 1 2 3 4 5))
  (printout t " " crlf)
  (printout t "How would you describe the cloud coverage 3 hours ago?" crlf)
  (printout t "    (1) clear" crlf)
  (printout t "    (2) partly-cloudy" crlf)
  (printout t "    (3) cloudy" crlf)
  (printout t "    (4) mostly-cloudy" crlf)
  (printout t "    (5) overcast" crlf)
  (printout t ">")
  (bind ?answer (read))
  (while (not (member ?answer ?allowed-values)) do
    (printout t "Please confine your answer to one of the above choices." crlf)
    (printout t ">")
    (bind ?answer (read)))
  (if (eq ?answer 1) then (modify ?f (cloud-cover clear)))
  (if (eq ?answer 2) then (modify ?f (cloud-cover partly-cloudy)))
  (if (eq ?answer 3) then (modify ?f (cloud-cover cloudy)))
  (if (eq ?answer 4) then (modify ?f (cloud-cover mostly-cloudy)))
  (if (eq ?answer 5) then (modify ?f (cloud-cover overcast))))
  
;***********
;Rule to prompt user for the earlier base height of primary clouds.
;***********

(defrule ask-earlier-primary-cloud-base
  ?f <- (old-data-from-user (cloud-cover ~clear)
                            (primary-cloud-base unasked))
  =>
  (bind ?allowed-values (create$ 1 2 3 4 5 6 7))
  (printout t " " crlf)
  (printout t "How would you describe the primary cloud base 3 hours ago?" crlf)
  (printout t "    (1) very, very low" crlf)
  (printout t "    (2) very low" crlf)
  (printout t "    (3) low" crlf)
  (printout t "    (4) middle" crlf)
  (printout t "    (5) high" crlf)
  (printout t "    (6) very high" crlf)
  (printout t "    (7) very, very high" crlf)
  (printout t ">")
  (bind ?answer (read))
  (while (not (member ?answer ?allowed-values)) do
    (printout t "Please confine your answer to one of the above choices." crlf)
    (printout t ">")
    (bind ?answer (read)))
  (if (eq ?answer 1) then (modify ?f (primary-cloud-base very very low)))
  (if (eq ?answer 2) then (modify ?f (primary-cloud-base very low)))
  (if (eq ?answer 3) then (modify ?f (primary-cloud-base low)))
  (if (eq ?answer 4) then (modify ?f (primary-cloud-base middle)))
  (if (eq ?answer 5) then (modify ?f (primary-cloud-base high)))
  (if (eq ?answer 6) then (modify ?f (primary-cloud-base very high)))
  (if (eq ?answer 7) then (modify ?f (primary-cloud-base very very high))))
  
;**********
;Rule to prompt user for the earlier orientation of primary clouds.
;**********

(defrule ask-earlier-primary-cloud-orientation
  ?f <- (old-data-from-user (cloud-cover ~clear)
                            (primary-cloud-orientation unasked))
  =>
  (bind ?allowed-values (create$ 1 2 3 4 5 6 ))
  (printout t " " crlf)
  (printout t "How would you describe the orientation of primary clouds 3 hours ago?" crlf)
  (printout t "    (1) very, very horizontal" crlf)
  (printout t "    (2) very horizontal" crlf)
  (printout t "    (3) horizontal" crlf)
  (printout t "    (4) vertical" crlf)
  (printout t "    (5) very vertical" crlf)
  (printout t "    (6) very, very vertical" crlf)
  (printout t ">")
  (bind ?answer (read))
  (while (not (member ?answer ?allowed-values)) do
    (printout t "Please confine your answer to one of the above choices." crlf)
    (printout t ">")
    (bind ?answer (read)))
  (if (eq ?answer 1) then (modify ?f (primary-cloud-orientation very very horizontal)))
  (if (eq ?answer 2) then (modify ?f (primary-cloud-orientation very horizontal)))
  (if (eq ?answer 3) then (modify ?f (primary-cloud-orientation horizontal)))
  (if (eq ?answer 4) then (modify ?f (primary-cloud-orientation vertical)))
  (if (eq ?answer 5) then (modify ?f (primary-cloud-orientation very vertical)))
  (if (eq ?answer 6) then (modify ?f (primary-cloud-orientation very very vertical))))
  
;**********
;Rule to prompt user for direction of earlier primary clouds.
;**********

(defrule ask-earlier-primary-cloud-direction
  ?f <- (old-data-from-user (cloud-cover ~clear)
                            (primary-clouds-moving-from unasked))
  =>
  (bind ?allowed-values (create$ 1 2 3 4 5 6 7 8 9 10))
  (printout t " " crlf)
  (printout t "From what direction were the primary clouds moving 3 hours ago?" crlf)
  (printout t "    (1)  not-applicable" crlf)
  (printout t "    (2)  unknown" crlf)
  (printout t "    (3)  north" crlf)
  (printout t "    (4)  northeast" crlf)
  (printout t "    (5)  east" crlf)
  (printout t "    (6)  southeast" crlf)
  (printout t "    (7)  south" crlf)
  (printout t "    (8)  southwest" crlf)
  (printout t "    (9)  west" crlf)
  (printout t "    (10) northwest" crlf)
  (printout t ">")
  (bind ?answer (read))
  (while (not (member ?answer ?allowed-values)) do
    (printout t "Please confine your answer to one of the above choices." crlf)
    (printout t ">")
    (bind ?answer (read)))
  (if (eq ?answer 1) then (modify ?f (primary-clouds-moving-from not-applicable)))
  (if (eq ?answer 2) then (modify ?f (primary-clouds-moving-from unknown)))
  (if (eq ?answer 3) then (modify ?f (primary-clouds-moving-from north)))
  (if (eq ?answer 4) then (modify ?f (primary-clouds-moving-from northeast)))
  (if (eq ?answer 5) then (modify ?f (primary-clouds-moving-from east)))
  (if (eq ?answer 6) then (modify ?f (primary-clouds-moving-from southeast)))
  (if (eq ?answer 7) then (modify ?f (primary-clouds-moving-from south)))
  (if (eq ?answer 8) then (modify ?f (primary-clouds-moving-from southwest)))
  (if (eq ?answer 9) then (modify ?f (primary-clouds-moving-from west)))
  (if (eq ?answer 10) then (modify ?f (primary-clouds-moving-from northwest)))) 

;************************************************************
;*                 MODULE:  PRINT-INPUT                     *
;************************************************************

(defmodule PRINT-INPUT (import MAIN ?ALL))

;**********
;Rule to print the header for the 3-hour-old observations.
;Note that we use salience factors to ensure our output
;is printed in the order we desire.
;**********

(defrule print-earlier-header
  (declare (salience 3))
  =>
  (printout t " " crlf)
  (printout t "-----------------------------------------" crlf)
  (printout t "|   Earlier Weather Data/Observations   |" crlf)
  (printout t "-----------------------------------------" crlf)
  (printout t " " crlf))

;**********
;Rule to print the 3-hour-old observations.
;**********

(defrule print-earlier-conditions
  (declare (salience 2))
  (old-data-from-user (primary-cloud-base $?primary-base)
                      (primary-cloud-orientation $?primary-orientation)
                      (primary-clouds-moving-from ?primary-moving-from)
                      (secondary-cloud-base $?secondary-base)
                      (secondary-cloud-orientation $?secondary-orientation)
                      (secondary-clouds-moving-from ?secondary-moving-from)
                      (cloud-cover ?cover))
  (old-data-from-computer (time-of-day ?time)
                          (month ?month)
                          (day-of-month ?day)
                          (wind-speed ?wind-speed)
                          (wind-from ?wind-from)
                          (barometric-pressure ?press)
                          (relative-humidity ?humidity))
  =>
  (printout t "Primary cloud base:            " (implode$ ?primary-base) crlf)
  (printout t "Primary cloud orientation:     " (implode$ ?primary-orientation) crlf)
  (printout t "Primary clouds moving from:    " ?primary-moving-from crlf)
  (printout t "Secondary cloud base:          " (implode$ ?secondary-base) crlf)
  (printout t "Secondary cloud orientation:   " (implode$ ?secondary-orientation) crlf)
  (printout t "Secondary clouds moving from:  " ?secondary-moving-from crlf)
  (printout t "Cloud cover:                   " ?cover crlf)
  (printout t "Time of day (0-23):            " ?time " hours " crlf)
  (printout t "Month (1-12):                  " ?month crlf)
  (printout t "Day of month (1-31):           " ?day crlf)
  (printout t "Wind speed (0-150):            " ?wind-speed " miles per hour" crlf)
  (printout t "Wind blowing from:             " ?wind-from " compass degrees" crlf)
  (printout t "Barometric pressure:           " ?press " inches of mercury" crlf)
  (printout t "Relative humidity:             " ?humidity " percent" crlf))

;**********
;Rule to print the header for the current observations.
;**********

(defrule print-current-header
  (declare (salience 1))
  =>
  (printout t " " crlf)
  (printout t "-----------------------------------------" crlf)
  (printout t "|   Current Weather Data/Observations   |" crlf)
  (printout t "-----------------------------------------" crlf)
  (printout t " " crlf))

;**********
;Rule to print the current observations.
;**********

(defrule print-current-conditions
  (new-data-from-user (primary-cloud-base $?primary-base)
                      (primary-cloud-orientation $?primary-orientation)
                      (primary-clouds-moving-from ?primary-moving-from)
                      (secondary-cloud-base $?secondary-base)
                      (secondary-cloud-orientation $?secondary-orientation)
                      (secondary-clouds-moving-from ?secondary-moving-from)
                      (cloud-cover ?cover))
  (new-data-from-computer (time-of-day ?time)
                          (month ?month)
                          (day-of-month ?day)
                          (wind-speed ?wind-speed)
                          (wind-from ?wind-from)
                          (barometric-pressure ?press)
                          (relative-humidity ?humidity))
  =>
  (printout t "Primary cloud base:            " (implode$ ?primary-base) crlf)
  (printout t "Primary cloud orientation:     " (implode$ ?primary-orientation) crlf)
  (printout t "Primary clouds moving from:    " ?primary-moving-from crlf)
  (printout t "Secondary cloud base:          " (implode$ ?secondary-base) crlf)
  (printout t "Secondary cloud orientation:   " (implode$ ?secondary-orientation) crlf)
  (printout t "Secondary clouds moving from:  " ?secondary-moving-from crlf)
  (printout t "Cloud cover:                   " ?cover crlf)
  (printout t "Time of day (0-23):            " ?time " hours " crlf)
  (printout t "Month (1-12):                  " ?month crlf)
  (printout t "Day of month (1-31):           " ?day crlf)
  (printout t "Wind speed (0-150):            " ?wind-speed " miles per hour" crlf)
  (printout t "Wind blowing from:             " ?wind-from " compass degrees" crlf)
  (printout t "Barometric pressure:           " ?press " inches of mercury" crlf)
  (printout t "Relative humidity:             " ?humidity " percent" crlf))

;************************************************************
;                  MODULE:  FUZZIFY                         *
;************************************************************

(defmodule FUZZIFY (import MAIN ?ALL) 
                   (import INPUT ?ALL)
                   (export ?ALL))
                   
;*****
;The fuzzify-fact function, which includes bounds checking to make 
;certain the produced values do not extend past the universe of
;discourse----this function takes CRISP facts and fuzzifies them
;for use in a fuzzy deftemplate or fuzzy fact.
;
;Reproduced from [ORC95], pp. 58.
;*****

;deffunction:  fuzzify-fact
;
;Inputs:  ?fztemplate - name of a fuzzy deftemplate
;         ?value      - float value to be fuzzified
;         ?delta      - precision of the value
;
; Asserts a fuzzy fact for the fuzzy deftemplate.  The fuzzy
; set is a triangular shape centered on the value provided with
; zero possibility at (value+delta) and (value-delta).  Note that
; it checks bounds of the universe of discourse to generate a fuzzy
; set that does not have values outside of the universe range.

(deffunction fuzzify-fact (?fztemplate ?value ?delta)

  (bind ?low (get-u-from ?fztemplate))
  (bind ?hi  (get-u-to   ?fztemplate))
  
  (if (<= ?value ?low)
    then
      (assert-string
        (format nil "(%s (%g 1.0) (%g 0.0))"
                ?fztemplate ?low ?delta))
                
    else
      (if (>= ?value ?hi)
        then
          (assert-string
            (format nil "(%s (%g 0.0) (%g 1.0))"
                    ?fztemplate (- ?hi ?delta) ?hi))
        else
          (assert-string
            (format nil "(%s (%g 0.0) (%g 1.0) (%g 0.0))"
                    ?fztemplate (max ?low (- ?value ?delta))
                    ?value (min ?hi (+ ?value ?delta)))))))
                    
                                       
              
;**********
;Template to hold the (fuzzy) current primary cloud base fact,
;based on cloud height data given in [FOR67], pp. 389-391.
;**********

(deftemplate ff-current-primary-cloud-base
  0 70 Kfeet
  (
  (low (z 0 6.5))
  (middle (pi 6.5 12))
  (high (s 18 20))
  ))                   

;**********
;Rule to fuzzify the current primary cloud base fact (only if
;the cloud cover is "not clear").  Note that we don't use
;the fuzzify-fact deffunction here.  This is because we're asserting
;a fuzzy fact (e.g. "ff-current-primary-cloud-based middle") 
;based on an already fuzzy fact (e.g. "primary-cloud-base middle")
;instead of a crisp fact.
;**********

(defrule fuzzify-current-primary-cloud-base
  (new-data-from-user (cloud-cover ~clear))
  (new-data-from-user (primary-cloud-base $?cbase))
  =>
  (assert-string (format nil "(ff-current-primary-cloud-base %s)"
                 (implode$ ?cbase))))
                 
;**********
;Template to hold the (fuzzy) current primary cloud orientation fact.
;**********

(deftemplate ff-current-primary-cloud-orientation
  0 10
  (
  (horizontal (z 1.5 7))
  (vertical (s 3 9.5))
  ))
  
;**********
;Rule to fuzzify the current primary cloud orientation fact.
;**********

(defrule fuzzify-current-primary-cloud-orientation
  (new-data-from-user (cloud-cover ~clear))
  (new-data-from-user (primary-cloud-orientation $?corientation))
  =>
  (assert-string (format nil "(ff-current-primary-cloud-orientation %s)"
                 (implode$ ?corientation))))
                
;**********
;Template to hold the (fuzzy) current primary cloud direction fact.
;**********

(deftemplate ff-current-primary-clouds-moving-from
  0 359 degrees
  (
  (north (0 1) (11.25 .875) (22.5 .5) (33.75 .125) (45 0)
         (315 0) (326.25 .125) (337.5 .5) (348.75 .875) (359 1))
  (northeast (pi 45 45))
  (east (pi 45 90))
  (southeast (pi 45 135))
  (south (pi 45 180))
  (southwest (pi 45 225))
  (west (pi 45 270))
  (northwest (pi 45 314))
  ))
  
;**********
;Rule to fuzzify the current primary cloud direction fact.
;**********

(defrule fuzzify-current-primary-clouds-moving-from
  (new-data-from-user (cloud-cover ~clear))
  (new-data-from-user (primary-clouds-moving-from ?direction))
  (test (neq ?direction unknown))
  (test (neq ?direction unasked))
  =>
  (assert-string (format nil "(ff-current-primary-clouds-moving-from %s)"
                  ?direction)))
  
;**********
;Template to hold the (fuzzy) current cloud cover fact.
;**********