<commit_before>;; This file is part of Sheeple

;; sheeplette.lisp
;;
;; An attempt at implementing a version of sheeple with a MOP.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :sheeple)
(defvar *max-sheep-id* 0)
(defparameter secret-unbound-value (gensym))
(defparameter secret-sheep-identifier (gensym))
(define-condition unbound-property (sheeple-error)
  ())

;;;
;;; Slot access
;;;
(defun get-property (sheep property-name)
  (if (eql (sheep-metaobject sheep) =standard-sheep-metaobject=)
      (std-get-property sheep property-name)
      (get-property-using-metaobject (sheep-metaobject sheep) sheep property-name)))
(defun std-get-property (sheep property-name)
  (gethash property-name sheep))

(defun (setf get-property) (new-value sheep property-name)
  (if (eql (sheep-metaobject sheep) =standard-sheep-metaobject=)
      (setf (std-get-property sheep property-name) new-value)
      (setf-get-property-using-metaobject 
       new-value (sheep-metaobject sheep) sheep property-name)))
(defun (setf std-get-property) (new-value sheep property-name)
  (setf (gethash property-name sheep) new-value))

;;;
;;; sheep storage
;;;
(defun std-generate-sheep-instance ()
  "Ex Nihilo creation of a standard sheep instance."
  (let ((table (make-hash-table :test #'equal)))
    (setf (gethash secret-sheep-identifier table)
	  secret-sheep-identifier)
    table))

(defun std-instance-p (sheep)
  (and (hash-table-p sheep)
       (eql (gethash secret-sheep-identifier sheep)
	    secret-sheep-identifier)))

(defun sheep-metaobject (sheep)
  (if (std-instance-p sheep)
      (gethash 'metaobject sheep)
      (sheep-metaobject-with-metaobject sheep)))

;;;
;;; Bootstrap
;;;
(format t "Bootstrapping Sheeplette...")

(defvar =standard-sheep-metaobject=
  (let ((object (std-generate-sheep-instance)))
    (setf (gethash 'metaobject object) object)
    (setf (gethash 'nickname object) nil)
    (setf (gethash 'parents object) nil)
    (setf (gethash 'children object) nil)
    (setf (gethash 'properties object) (make-hash-table :test #'equal))
    (setf (gethash 'property-owners object) (make-hash-table :test #'equal))
    (setf (gethash 'roles object) nil)
    (setf (gethash 'hierarchy-list object) nil)
    object))

(defun generate-sheep-object (&key (metaobject =standard-sheep-metaobject=))
  (if (eql metaobject =standard-sheep-object=)
      (let ((object (make-hash-table :test #'equal)))
	(setf (gethash 'metaobject object) metaobject)
	object)
      (generate-sheep-object-using-metaobject metaobject)))

(defvar =dolly= (generate-sheep-object))

;;;
;;; Cloning
;;;

;;; The Macro
;; Example: (clone (sheep1 sheep2 sheep3) ((property1 value1) (property2 value2)))
(defmacro clone (sheeple properties &rest options)
  "Standard sheep-generation macro"
  `(spawn-sheep
    ,(canonize-sheeple sheeple)
    ,(canonize-properties properties)
    ,@(canonize-options options)))

;;;
;;; Canonizers
;;;
(defun canonize-sheeple (sheeple)
  `(list ,@(mapcar #'canonize-sheep sheeple)))

(defun canonize-sheep (sheep)
  `(confirm-sheep ,sheep))

(defun confirm-sheep (sheep)
  (if (eql (class-of sheep)
	   (find-class 'standard-sheep))
      sheep
      (sheepify sheep)))

(defun canonize-properties (properties)
  `(list ,@(mapcar #'canonize-property properties)))

(defun canonize-property (property)
  (if (symbolp property)
      `(list :name ',property)
      (let ((name (car property))
	    (value (cadr property))
            (readers nil)
            (writers nil)
	    (locked-p nil)
	    (cloneform *secret-unbound-value*)
            (other-options nil))
        (do ((olist (cddr property) (cddr olist)))
            ((null olist))
	  (case (car olist)
	    (:value
	     (setf value (cadr olist)))
	    (:val
	     (setf value (cadr olist)))
            (:reader 
             (pushnew (cadr olist) readers))
            (:writer 
             (pushnew (cadr olist) writers))
            (:manipulator
             (pushnew (cadr olist) readers)
             (pushnew `(setf ,(cadr olist)) writers))
	    (otherwise 
             (pushnew (cadr olist) other-options)
             (pushnew (car olist) other-options))))
	(if other-options
	    (error "Invalid property option(s)")
	    `(list
	      :name ',name
	      :value ,value
	      ,@(when readers `(:readers ',readers))
	      ,@(when writers `(:writers ',writers)))))))

(defun canonize-options (options)
  `(list ,@(mapcar #'canonize-option options)))

(defun canonize-option (option)
  `(list ,@option))

;;;
;;; Create-a-sheep
;;;
(defun spawn-sheep (sheeple properties
		    &rest all-keys
		    &key (metaobject =standard-sheep-metaobject=)
		    &allow-other-keys)
  "Creates a new sheep with SHEEPLE as its parents, and PROPERTIES as its properties"
  (let ((sheep (generate-sheep-object :metaobject metaobject)))
    (set-up-inheritance sheep sheeple)
    (set-up-properties sheep properties)
    (set-up-other-options sheep options)
    (finalize-sheep sheep)
    sheep))

(defun set-up-inheritance (sheep the-parents)
  (if (eql (sheep-metaobject sheep) =standard-sheep-metaobject=)
      (std-set-up-inheritance sheep the-parents)
      (set-up-inheritance-using-metaobject (sheep-metaobject sheep) sheep the-parents)))
(defun std-set-up-inheritance (sheep parents)
  (let ((obj new-sheep))
    (if sheeple
	(loop for sheep in (nreverse sheeple)
	   do (add-parent sheep obj))
	(add-parent =dolly= obj))
    obj))

(defun set-up-properties (sheep properties)
  (loop for property-list in properties
     do (set-up-property property-list sheep)))
(defun set-up-property (sheep property)
  (if (eql (sheep-metaobject sheep) =standard-sheep-metaobject=)
      (std-set-up-property sheep property)
      (set-up-property-using-metaobject 
       (sheep-metaobject sheep) sheep property)))
(defun std-set-up-property (sheep property)
  (defmethod set-up-property (property-list (sheep standard-sheep))
  (let ((name (getf property-list :name))
	(value (getf property-list :value))
	(readers (getf property-list :readers))
	(writers (getf property-list :writers))
	(locked-p (getf property-list :lock)))
    (when (keywordp name)
      (error 'probably-meant-to-be-option))
    (setf (get-property sheep name) value)
    (when locked-p
      (lock-property sheep name))
    (add-readers-to-sheep readers name sheep)
    (add-writers-to-sheep writers name sheep))))

(define-condition invalid-option-error (sheeple-error) ())<commit_msg>Nicer. I think I understand better...<commit_after>;; This file is part of Sheeple

;; sheeplette.lisp
;;
;; An attempt at implementing a version of sheeple with a MOP.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :sheeple)
(defvar *max-sheep-id* 0)
(defparameter secret-unbound-value (gensym))
(defparameter secret-sheep-identifier (gensym))
(define-condition unbound-property (sheeple-error)
  ())

;;;
;;; Slot access
;;;
(defun get-property (sheep property-name)
  (if (eql (sheep-metaobject sheep) =standard-sheep-metaobject=)
      (std-get-property sheep property-name)
      (get-property-using-metaobject (sheep-metaobject sheep) sheep property-name)))
(defun std-get-property (sheep property-name)
  (gethash property-name sheep))

(defun (setf get-property) (new-value sheep property-name)
  (if (eql (sheep-metaobject sheep) =standard-sheep-metaobject=)
      (setf (std-get-property sheep property-name) new-value)
      (setf-get-property-using-metaobject 
       new-value (sheep-metaobject sheep) sheep property-name)))
(defun (setf std-get-property) (new-value sheep property-name)
  (setf (gethash property-name sheep) new-value))

;;;
;;; sheep storage
;;;
(defun std-generate-sheep-instance ()
  "Ex Nihilo creation of a standard sheep instance."
  (let ((table (make-hash-table :test #'equal)))
    (setf (gethash secret-sheep-identifier table)
	  secret-sheep-identifier)
    table))

(defun std-instance-p (sheep)
  (and (hash-table-p sheep)
       (eql (gethash secret-sheep-identifier sheep)
	    secret-sheep-identifier)))

(defun sheep-metaobject (sheep)
  (get-property sheep 'metaobject))

;;;
;;; Bootstrap
;;;
(defvar =standard-sheep-metaobject=
  (let ((object (std-generate-sheep-instance)))
    (setf (gethash 'metaobject object) object)
    (setf (gethash 'nickname object) nil)
    (setf (gethash 'parents object) nil)
    (setf (gethash 'children object) nil)
    (setf (gethash 'properties object) (make-hash-table :test #'equal))
    (setf (gethash 'property-owners object) (make-hash-table :test #'equal))
    (setf (gethash 'roles object) nil)
    (setf (gethash 'hierarchy-list object) nil)
    object))

(defun generate-sheep-object (&key (metaobject =standard-sheep-metaobject=))
  (if (eql metaobject =standard-sheep-object=)
      (let ((object (make-hash-table :test #'equal)))
	(setf (gethash 'metaobject object) metaobject)
	object)
      (generate-sheep-object-using-metaobject metaobject)))

(defvar =dolly= (generate-sheep-object))

;;;
;;; Cloning
;;;

;;; The Macro
;; Example: (clone (sheep1 sheep2 sheep3) ((property1 value1) (property2 value2)))
(defmacro clone (sheeple properties &rest options)
  "Standard sheep-generation macro"
  `(spawn-sheep
    ,(canonize-sheeple sheeple)
    ,(canonize-properties properties)
    ,@(canonize-options options)))

;;;
;;; Canonizers
;;;
(defun canonize-sheeple (sheeple)
  `(list ,@(mapcar #'canonize-sheep sheeple)))

(defun canonize-sheep (sheep)
  `(confirm-sheep ,sheep))

(defun confirm-sheep (sheep)
  (if (eql (class-of sheep)
	   (find-class 'standard-sheep))
      sheep
      (sheepify sheep)))

(defun canonize-properties (properties)
  `(list ,@(mapcar #'canonize-property properties)))

(defun canonize-property (property)
  (if (symbolp property)
      `(list :name ',property)
      (let ((name (car property))
	    (value (cadr property))
            (readers nil)
            (writers nil)
	    (locked-p nil)
	    (cloneform *secret-unbound-value*)
            (other-options nil))
        (do ((olist (cddr property) (cddr olist)))
            ((null olist))
	  (case (car olist)
	    (:value
	     (setf value (cadr olist)))
	    (:val
	     (setf value (cadr olist)))
            (:reader 
             (pushnew (cadr olist) readers))
            (:writer 
             (pushnew (cadr olist) writers))
            (:manipulator
             (pushnew (cadr olist) readers)
             (pushnew `(setf ,(cadr olist)) writers))
	    (otherwise 
             (pushnew (cadr olist) other-options)
             (pushnew (car olist) other-options))))
	(if other-options
	    (error "Invalid property option(s)")
	    `(list
	      :name ',name
	      :value ,value
	      ,@(when readers `(:readers ',readers))
	      ,@(when writers `(:writers ',writers)))))))

(defun canonize-options (options)
  `(list ,@(mapcar #'canonize-option options)))

(defun canonize-option (option)
  `(list ,@option))

;;;
;;; Create-a-sheep
;;;
(defun spawn-sheep (sheeple properties
		    &rest all-keys
		    &key (metaobject =standard-sheep-metaobject=)
		    &allow-other-keys)
  "Creates a new sheep with SHEEPLE as its parents, and PROPERTIES as its properties"
  (let ((sheep (generate-sheep-object :metaobject metaobject)))
    (set-up-inheritance sheep sheeple)
    (set-up-properties sheep properties)
    (set-up-other-options sheep options)
    (finalize-sheep sheep)
    sheep))

(defun set-up-inheritance (sheep the-parents)
  (if (eql (sheep-metaobject sheep) =standard-sheep-metaobject=)
      (std-set-up-inheritance sheep the-parents)
      (set-up-inheritance-using-metaobject (sheep-metaobject sheep) sheep the-parents)))
(defun std-set-up-inheritance (sheep parents)
  (let ((obj new-sheep))
    (if sheeple
	(loop for sheep in (nreverse sheeple)
	   do (add-parent sheep obj))
	(add-parent =dolly= obj))
    obj))

(defun set-up-properties (sheep properties)
  (loop for property-list in properties
     do (set-up-property property-list sheep)))
(defun set-up-property (sheep property)
  (if (eql (sheep-metaobject sheep) =standard-sheep-metaobject=)
      (std-set-up-property sheep property)
      (set-up-property-using-metaobject 
       (sheep-metaobject sheep) sheep property)))
(defun std-set-up-property (sheep property)
  (defmethod set-up-property (property-list (sheep standard-sheep))
  (let ((name (getf property-list :name))
	(value (getf property-list :value))
	(readers (getf property-list :readers))
	(writers (getf property-list :writers)))
    (when (keywordp name)
      (error 'probably-meant-to-be-option))
    (setf (get-property sheep name) value)
    (add-readers-to-sheep readers name sheep)
    (add-writers-to-sheep writers name sheep))))

(define-condition invalid-option-error (sheeple-error) ())
{'fraction_non_alphanumeric': 0.1580262336039975, 'fraction_numerical': 0.0012492192379762648, 'mean_word_length': 3.5959813419447433, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2806199', 'n_tokens_mistral': 4472, 'n_tokens_neox': 4348, 'n_words': 1091}