;;; -*- Mode: Lisp; Package: Prolog; Base: 10; Options: ((world System)) -*-
;;; (C) Copyright 1983,1984,1985, Uppsala University

;;this file contains LM-Prolog predicates for customizing the system

(define-predicate make-true 
  (:options (:lisp-macro-name make-true)
	    (:argument-list (&rest predications))
	    (:documentation ("is an operator upon predications.
 Rather than having predicates for changing the CIRCULARITY-MODE,
 the OPTION, the current UNIVERSE, the handling of INTERRUPTS,
 the PROTECTED-WORLDS, or the DELAYED-VALUE-MODE, the predicate MAKE-TRUE is used.
  The predication (MAKE-TRUE (CIRCULARITY-MODE :HANDLE)) always
 succeeds and sets the mode to :handle.")))
  ((make-true (?predicator . ?arguments))
   (cases ((can-prove (definition ? ?predicator))
	   (either (*make-true* (?predicator . ?arguments))
		   (?predicator . ?arguments)))
	  ((assert ((?predicator . ?arguments))))))
  ((make-true ?predication-1 ?predication-2 . ?more)
   (make-true (and ?predication-1 ?predication-2 . ?more))))

(define-predicate circularity-mode
  (:options (:argument-list (mode))
	    (:documentation "unifies MODE with the current circularity mode, which is either
 :ignore, :handle, or :prevent."))
  ((circularity-mode ?ignore-handle-or-prevent)
   (lisp-value ?ignore-handle-or-prevent *circularity-mode* :dont-invoke)))

(define-predicate *make-true*
  (:options (:if-old-definition :keep))
  (:change-circularity-mode
    (*make-true* (circularity-mode ?ignore-handle-or-prevent))
    (lisp-command (set-circularity-mode '?ignore-handle-or-prevent) :dont-invoke)))

(define-predicate *current-value-finder*
  (:options (:if-old-definition :keep))
  (:circularity-mode-finder
    (*current-value-finder* (circularity-mode ?ignore-value)
			    (circularity-mode ?))))

(define-predicate delayed-value-mode
  (:options (:argument-list (mode))
	    (:documentation "inspects the default mode of interfacing Prolog and Lisp.
 Unifies MODE with the default action taken when Prolog calls
 Lisp. The value can be :copy, :invoke, :query, or :dont-invoke.
 It is :query initially."))
  ((delayed-value-mode ?mode)
   (lisp-value ?mode *default-lisp-form-mode* :dont-invoke)))

(define-predicate *make-true*
  (:options (:if-old-definition :keep))
  (:change-delayed-value-mode
    (*make-true* (delayed-value-mode ?mode))
    (lisp-command (set-default-lisp-form-mode '?mode) :dont-invoke)))

(defun set-default-lisp-form-mode (mode)
  (cond ((memq mode '(:invoke :dont-invoke :query :copy))
	 (setq *default-lisp-form-mode* mode))
	(t (prolog-error ':bad-delayed-value-mode
			 "~s should be either :invoke :dont-invoke :query :copy"
			 mode))))

(define-predicate *current-value-finder*
  (:options (:if-old-definition :keep))
  (:delayed-value-mode-finder
    (*current-value-finder* (delayed-value-mode ?ignore-value)
			    (delayed-value-mode ?))))

(define-predicate protected-worlds
  ((protected-worlds ?worlds)
   (lisp-value ?worlds *protected-worlds* :dont-invoke)))

(define-predicate *make-true*
  (:options (:if-old-definition :keep))
  (:change-protected-worlds
    (*make-true* (protected-worlds ?worlds))
    (either (ground ?worlds)
	    (error 'bad-change-to-protected-worlds
		   "~S must be a ground list." ?worlds))
    (lisp-command (setq *protected-worlds* '?worlds) :copy)))

(define-predicate *current-value-finder*
  (:options (:if-old-definition :keep))
  (:protected-worlds-finder
    (*current-value-finder* (protected-worlds ?ignore-worlds)
			    (protected-worlds ?))))

(define-predicate option
  (:options (:argument-list ((option-name &rest values) &optional predicator world universe))
	    (:documentation "unifies VALUES with the default values for DEFINE-PREDICATE
 option OPTION-NAME.  If PREDICATOR is supplied, OPTION-NAME and VALUES are unified with
 option name and values for it."))
  ((option ?option)
   (lisp-value (? . ?options) *default-options* :dont-invoke)
   (member ?option ?options))
  ((option ?option ?predicator . ?world-worlds)
   (definition (define-predicate ? (? . ?options) . ?) ?predicator . ?world-worlds)
   (member ?option ?options)))

(define-predicate *make-true*
  (:options (:if-old-definition :keep))
  (:change-default-option
    (*make-true* (option ?option))
    (lisp-command (set-default-define-option '?option) :copy))
  (:change-predicates-options
    ;;the following is not too expensive since the clauses are passed around
    ;;as instances.
    (*make-true* (option (?option-name . ?values) ?predicator . ?world-worlds))
    (definition (define-predicate ? ?old-options . ?clauses)
		?predicator . ?world-worlds)
    (substitute ?new-options
		(?option-name . ?) (?option-name . ?values) ?old-options =)
    (define-predicate ?predicator ?new-options . ?clauses)))

;;the following is now an unnecessary special case handling
;;(defun copy-predicate-to-world (predicator old-world new-world)
;;  (let* ((old-definition (definition-in-world predicator old-world))
;;	 (new-definition (copylist old-definition))
;;	 (new-options (replace-world-in-options (definition-options old-definition)
;;						new-world)))
;;    (setf (definition-options new-definition) new-options)
;;    (add-to-world predicator new-definition new-world)))
		  
;;(deffun replace-world-in-options (options new-world)
;;  (cond ((null options) nil)
;;	((and (consp (first options)) (eq (first (first options)) ':world))
;;	 (cons (list ':world new-world) (rest1 options)))
;;	(t (cons (first options)
;;		 (replace-world-in-options (rest1 options) new-world)))))

(define-predicate *current-value-finder*
  (:options (:if-old-definition :keep))
  (:option-finder
    (*current-value-finder* (option (?option-name . ?ignore-values) . ?arguments)
			    (option (?option-name . ?) . ?arguments))
    (symbol ?option-name)))

(defun set-default-define-option (option)
  (setq *default-options* (merge-options `(:options ,option) *default-options*)))