🚀 go-pugleaf

;;; -*- Mode:Common-Lisp; Fonts:(MEDFNT MEDFNTB HL12BI HL12B CPTFONTB); Base:10 -*-

;1;; if you've been faced with converting FLAVORs to CLOS,*
;1;; this stuff should help.*

;1;; it is by no means complete, or perfect, but it's a good headstart.*
;1;; for example, the stranger things of FLAVOR options are mostly *
;1;; or simply have no equivalent or are not here yet,*
;1;; nor are conversions of things inside METHODs.*

(DEFMACRO 4convert-flavor-to-class* ((ignore name IVs incl &body body)
				   &aux (temp ()) (defs ()) (doc ""))
  "2Converts a FLAVOR definition into a CLASS definition.*"
  (DOLIST (iv IVs (SETQ temp (REVERSE temp)))
    (IF (ATOM iv)
	(PUSH (LIST iv :initform ()) temp)
	(PUSH (LIST (CAR iv) :initform
		    (IF (SYMBOLP (CADR iv))
			(CADR iv)))
	      temp)))
  
  (DOLIST (stuff body)
    
    ;1;fix up the things which are currently understood.*
    (IF (LISTP stuff)
	;1;THEN, it was a list of specific things.*
	(CASE (CAR stuff)
	  ;1; :gettable-IVs become :reader entries.*
	  (:gettable-instance-variables (DOLIST (iv (CDR stuff))
					  (SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
										 (EQUAL iv (CAR tmp))))
						     temp)
						(APPEND (FIND iv temp :test #'(lambda (iv tmp)
										(EQUAL iv (CAR tmp))))
							(LIST :reader IV)
							))))
	  ;1; :settable-IVs become :accessor entries.*
	  (:settable-instance-variables (DOLIST (iv (CDR stuff))
					  (SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
										 (EQUAL iv (CAR tmp))))
						     temp)
						(APPEND (FIND iv temp :test #'(lambda (iv tmp)
										(EQUAL iv (CAR tmp))))
							(LIST :accessor IV :initarg
							      (READ-FROM-STRING (FORMAT () "3:~S*" IV)))
							))))
	  ;1; :inittable-IVs become :initform entries.*
	  (:inittable-instance-variables (DOLIST (iv (CDR stuff))
					   (SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
										  (EQUAL iv (CAR tmp))))
						      temp)
						 (APPEND (FIND iv temp :test #'(lambda (iv tmp)
										 (EQUAL iv (CAR tmp))))
							 (LIST :initarg (FORMAT () "3:~S*" IV))
							 ))))
	  ;1; the :default-init-plist behaves differently, because it*
	  ;1; doesn't go into the IV slot def. it tacks on at the end,*
	  ;1; in much the same way as with the flavor.*
	  (:default-init-plist (SETQ defs (LIST (CONS :default-initargs (CDR stuff)))))
	  (:REQUIRED-FLAVORS (SETQ incl (APPEND incl (CDR stuff))))
	  (:REQUIRED-INSTANCE-VARIABLES (SETQ IVs (APPEND IVs (CDR stuff))))
	  (:INCLUDED-FLAVORS (SETQ incl (APPEND incl (CDR stuff))))
	  (:DOCUMENTATION (SETQ doc (CDR stuff)))
	  )
	;1;ELSE, it was an atomic item, meaning ALL IVs get this attribute.*
	(CASE stuff
	  (:settable-instance-variables (DOLIST (iv IVs)
					  (SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
										 (EQUAL (IF (LISTP iv)
											    (CAR iv)
											    iv)
											(CAR tmp))))
						     temp)
						(APPEND (FIND iv temp :test #'(lambda (iv tmp)
										(EQUAL (IF (LISTP iv)
											   (CAR iv)
											   iv)
										       (CAR tmp))))
							(LIST :accessor IV :initarg (FORMAT () "3:~S*" IV))
							))))
	  (:inittable-instance-variables (DOLIST (iv IVs)
					   (SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
										  (EQUAL (IF (LISTP iv)
											     (CAR iv)
											     iv)
											 (CAR tmp))))
						      temp)
						 (APPEND (FIND iv temp :test #'(lambda (iv tmp)
										 (EQUAL (IF (LISTP iv)
											   (CAR iv)
											   iv)
											(CAR tmp))))
							 (LIST :initarg (FORMAT () "3:~S*" IV))
							 ))))
	  (:gettable-instance-variables (DOLIST (iv IVs)
					  (SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
										 (EQUAL (IF (LISTP iv)
											     (CAR iv)
											     iv)
											(CAR tmp))))
						     temp)
						(APPEND (FIND iv temp :test #'(lambda (iv tmp)
										(EQUAL (IF (LISTP iv)
											   (CAR iv)
											   iv)
										       (CAR tmp))))
							(LIST :reader IV)
							)))))
	))
  ;1;if there's something else...*
  ;1;first remove all the things which were dealt with in the CASE.*
  (DOLIST (r (LIST :inittable-instance-variables :default-init-plist
		   :gettable-instance-variables :settable-instance-variables
		   :REQUIRED-METHODS :REQUIRED-INSTANCE-VARIABLES
		   :DOCUMENTATION :INCLUDED-FLAVORS 
		   ))
    
    ;1;these items have no direct equivalent in CLOS.*
;1 * (:DEFAULT-HANDLER function)
;  :NO-VANILLA-FLAVOR
;  (:METHOD-ORDER m1 m2...)
;  (:METHOD-COMBINATION (type order operation1 operation2...)...)
;  (:SPECIAL-INSTANCE-VARIABLES <variables>)
;  :ABSTRACT-FLAVOR 
;  :ALIAS-FLAVOR

    ;1;keep what remains*
    (SETQ body (REMOVE r body :test #'(lambda (opt tmp)
					(EQUAL opt (IF (LISTP tmp)
						       (CAR tmp)
						       tmp))))))
  ;1;return this*
  `(defclass
      ,name
      ,incl
      ,temp
      ,@defs
      ,@(IF body
	    '("3This next bunch is still left from the Flavor def'n, and needs to be changed.*")
	    ())
      ,@body)
  )

;1;;a test case with variety.*
(COMMENT
  print (convert-flavor-to-class
	  (DEFFLAVOR radio-button (center-x center-y radius window string (font ()) (on ())
				   left top right bottom (polygon (MAKE-ARRAY 60)))
		     ()
	    (:gettable-instance-variables radius left top right bottom)
	    (:settable-instance-variables center-x center-y window string font on)
	    ;1(:default-init-plist :string "")*
	    ;1(:doodled-up things which do nowhere)*
	    ;1(:doodled-up which nowhere things go)*
	    )
	  ))

;1;;***********************************************************************
;1;;***********************************************************************

;1;;now to convert methods. this also converts instances of (SEND self :xx args)*
;1;; into (xx self args)*

(DEFMACRO 4convert-flav-meth-to-clos-meth* ((IGNORE name args &body body) &aux (doc-str ()))
  ;1;do the make-inst so that we can find all the slots.*
    (IF (AND (NOT (GET (CAR name) 'sys:flavor))	   ;1it's NOT a flavor*
	     (GET (CAR name) 'ticlos:class-def)   ;1it IS a class*
	     )
	(IF (NOT (ticlos:class-composed-p (find-class (CAR name))))	   ;1it's already been composed.*
	    (MAKE-INSTANCE (CAR name))	   ;1make an instance. this "composes" the class.*
	    )
	(ERROR "3You need to compile the DEFCLASS first.
I can't convert methods until you do.*"))

  ;1;get the doc-str in the right place.*
  (WHEN (STRINGP (CAR body))
    (SETQ doc-str (LIST (CAR body)))
    (SETQ body (CDR body)))
  
  ;1;now do the conversion.*
  `(DEFMETHOD ,(IF (THIRD name)		   ;1the method-name*
		   (READ-FROM-STRING (SYMBOL-NAME (THIRD name)))
		   (READ-FROM-STRING (SYMBOL-NAME (SECOND name))))
	      ,@(IF (THIRD name)	   ;1the daemon*
		    (READ-FROM-STRING (SYMBOL-NAME (SECOND name))))
     ,(CONS (LIST 'myself (FIRST name))	   ;1self isn't right here, but will do for now.*
	    args)			   ;1the cons is for when args is NIL. couldn't do @.*
     ,@doc-str
     ,@(IF body
	  `((with-slots ,(MAPCAR #'(lambda (slot)
				     (LIST (ticlos:slot-name slot) (ticlos:slot-name slot)))
				 (class-slots (find-class (CAR name))))
			myself
	      ,@(convert-flav-send-self-walker body)))))
  )

;1;;***********************************************************************

;1;; now for a code-walker with which to replace (SEND self ...) calls.*

(DEFUN 4convert-flav-send-self-walker *(body)
  (MAPCAR #'(lambda (form)
	      (IF (LISTP form)
		(IF (AND (EQUAL (CAR form)  'SEND)
			 (EQUAL (CADR form) 'self))
		    `(,(READ-FROM-STRING (SYMBOL-NAME (THIRD form)))
		      self
		      ,@(CDDDR form))
		    (walk form)
		    )
		form))
	  body))

;1;;***********************************************************************
;1;;***********************************************************************

;1;;a test case.*
(;COMMENT
  convert-flav-meth-to-clos-meth
  (DEFMETHOD (radio-button :setup) ()
    (UNLESS font (SETQ font fonts:cptfont))
    (UNLESS window (ERROR "3You  didn't specify a window for this Radio-Button.*"))
    (SETQ radius (- (FLOOR (/ (w:font-char-height font) 2)) 1)
	  left   (- center-x radius 1)
	  right  (+ center-x radius 1)
	  top    (- center-y radius 1)
	  bottom (+ center-y radius 1)
	  )
    )
  )
 

;(convert-flav-meth-to-clos-meth
; (DEFMETHOD 4(radio-button :refresh)* ()
;  ;1;do something to refresh the region*
;  ;(SEND window :draw-circle center-x center-y radius 1 w:black w:normal 30)
;  (tv:sheet-string-out-explicit-1 window string (+ center-x radius 4) (- center-y radius )
;				  () () font w:normal)
;  (SEND self :draw-radio-button)
;  )
;  )


;(DEFMETHOD 4refresh* ((self radio-button))
;  (with-slots ((center-x center-x) (center-y center-y) (radius radius) (window window)
;	       (STRING string) (font font) (on on) (left left) (top top) (right right)
;	       (bottom bottom) (polygon polygon)) self
;    (tv::sheet-string-out-explicit-1 window string (+ center-x radius 4) (- center-y radius) nil
;				     nil font w:normal)
;    (draw-radio-button self))) 

;1;;***********************************************************************
;1;;***********************************************************************
;1;;***********************************************************************

;1;; END of file CONVERT-FLAV-TO-CLASS*

;1;;***********************************************************************
;1;;***********************************************************************
;1;;**********************************************************************