;;; pure-ds.el --- Data structure definition for PURE

;; Copyright (C) 2001  Project Pure.

;; Author: SHIMADA Mitsunobu <simm@pure.fan.gr.jp>
;; Keywords: PURE, data structure

;; $Id: pure-ds.el,v 1.4 2001/06/05 16:09:49 simm Exp $

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; PURE means "Primitive Universal Relay-chat Environment"
;; DS means "Data Structure"

;;; Code:
(defmacro pure-ds-define (class &rest args)
  "Define data structure and functions/macros below:

-- Function: CLASS-make &optional ARGS
    Make CLASS-type object.

-- Macro: CLASS-compare OBJ1 OBJ2 &optional OP &rest ARGS
    Compare OBJ1 with OBJ2 as CLASS-type object.

-- Macro: CLASS-get-ITEM OBJ
    Get item ITEM of CLASS-type object OBJ.

-- Macro: CLASS-put-ITEM OBJ VALUE
    Put item ITEM of CLASS-type object OBJ to VALUE.

-- Macro: CLASS-cmp-ITEM OBJ1 OBJ2 &optional OP
    Compare item ITEM of CLASS-type object OBJ1 with OBJ2, compared by OP."
  (let ((size (1+ (length args))))
    (append
     (list
      'progn
      (list 'put (list 'quote class) ''pure-ds-items (list 'quote args))
      (list 'defsubst (intern (format "%s-make" class)) (cons '&optional args)
	    (format "Make `%s'-type object" class)
	    (cons 'vector (cons (list 'quote class) args)))
      (list 'defmacro (intern (format "%s-compare" class)) '(obj1 obj2 &optional op &rest args)
	    (format "Compare OBJ1 with OBJ2 as `%s'-type object" class)
	    (list 'list ''pure-ds-compare-args (list 'quote class) 'obj1 'obj2 'op 'args)))
     (apply
      'append
      (mapcar
       (function
	(lambda (item)
	  (list
	   (list 'defmacro (intern (format "%s-get-%s" class item)) '(obj)
		 (format "Get item %s of `%s'-type object OBJ"
			 (upcase (format "%s" item)) class)
		 (list 'list ''aref 'obj (- size (length (memq item args)))))
	   (list 'defmacro (intern (format "%s-put-%s" class item)) '(obj value)
		 (format "Put item %s of `%s'-type object OBJ to VALUE"
			 (upcase (format "%s" item)) class)
		 (list 'list ''aset 'obj (- size (length (memq item args))) 'value))
	   (list 'defmacro (intern (format "%s-cmp-%s" class item))
		 '(obj1 obj2 &optional op)
		 (format (concat "Compare item %s of `%s'-type object OBJ1 with OBJ2, "
				 "compared by OP")
			 (upcase (format "%s" item)) class)
		 (list 'list '(or op 'eq)
		       (list 'list ''aref 'obj1 (- size (length (memq item args))))
		       (list 'list ''aref 'obj2 (- size (length (memq item args)))))))))
       args)))))

(defsubst pure-ds-get-class (obj)
  "Get class of OBJ. If OBJ isn't pure-ds class, returns nil."
  (and (arrayp obj)
       (aref obj 0)))

(defun pure-ds-get-item (obj item)
  "Get ITEM of OBJ"
  (if (stringp item)
      item
    (let ((classes (get (aref obj 0) 'pure-ds-items)))
      (aref obj (1+ (- (length classes) (length (memq item classes))))))))

(defun pure-ds-compare-args (class obj1 obj2 &optional op args)
  "Compare OBJ1 with OBJ2, given ARGS corresponds. Each element is compared by OP."
  (and (= (length obj1) (length obj2))
       (eq class (aref obj1 0))
       (eq class (aref obj2 0))
       (eval
	(macroexpand
	 (cons 'and
	       (mapcar
		(function
		 (lambda (item)
		   (eval
		    (macroexpand
		     (list (intern (format "%s-cmp-%s" class item)) obj1 obj2 op)))))
		(or args (get class 'pure-ds-items))))))))

(defmacro pure-ds-add-list (obj olist)
  "Add OBJ to OLIST"
  (list 'or
	(list 'member obj olist)
	(list 'setq olist (list 'cons obj olist))))

(defmacro pure-ds-del-list (obj olist)
  "Delete OBJ from OLIST"
  (list 'let (cons (list 'item (list 'member obj olist)) nil)
	(list 'if 'item
	      (list 'setq olist (list 'delq '(car item) olist)))))

;; That's all
(provide 'pure-ds)

;;; pure-ds.el ends here