LispForum

Code: Select all

(defclass function-sketch ()
  ((name
    :initarg :name
    :initform (error "Must supply :name <function-sketch-name>")
    :accessor name
    :documentation "The name of the function-sketch")
   (test-list
    :initarg :test-list
    :initform '()
    :accessor test-list
    :documentation "A list of cons cells looking like (<input-arguments-in-a-list> . <wished-for-return-value>)")
   (description
    :initarg :description
    :initform ""
    :accessor description
    :documentation "A human readable description of why this function should be written.")
   (implementations
    :initarg :implementations
    :initform '()
    :accessor implementations
    :documentation "A list containing valid implementations of the sketched function.")))

(defmethod print-object ((object function-sketch) stream)
  (print-unreadable-object (object stream :type t)
    (with-slots (name test-list description) object
      (let ((print-list (loop for i in test-list 
                           collect name 
                           collect (car i) 
                           collect (cdr i))))
        (format stream 
                "~%~a~%~%Description:~%~a~%~%Tests to satisfy:~%~{(~a~{ ~a~^~}) ==> ~a~%~}" 
                name description print-list)))))

(defvar *function-sketch-lib* (make-array 1000 :adjustable t :fill-pointer 0))

(defun clear-sketch-lib ()
  (setf
   *function-sketch-lib* (make-array 1000 :adjustable t :fill-pointer 0)))

(defparameter *passed?* t)

(defun compare-to-sketch (user-fct sketch-object)
  (with-slots (test-list) sketch-object
      (loop for f in test-list do (report-result user-fct (car f) (cdr f)))))

(defun report-result (user-fct arglst wished-for-result)
  (if (equal (apply user-fct arglst) wished-for-result)
      (format t "Score! (~a~{ ~a~}) evaluated to ~a.~%"  user-fct arglst (apply user-fct arglst))
      (progn 
	(format t "Something's wrong. (~a~{ ~a~}) evaluated to ~a.~%"  user-fct arglst (apply user-fct arglst))
	(setf *passed?* nil))))

(defun assure-implementations (function-sketch-object)
  (loop for i in (implementations function-sketch-object)
     do (compare-to-sketch (eval i) function-sketch-object) 
       (when (not *passed?*) 
	 (setf (implementations function-sketch-object) (delete i (implementations function-sketch-object)))
	 (format t "Removed ~a from implementations list." i)
	 (setf *passed?* t))))

(defun append-test-list (function-sketch-object test-list)
  (setf (test-list function-sketch-object) (append (test-list function-sketch-object) test-list))
  (assure-implementations function-sketch-object))

(defun set-test-list (function-sketch-object test-list)
  (setf (test-list function-sketch-object) test-list)
  (assure-implementations function-sketch-object))

(defun set-description (function-sketch-object description)
  (setf (description function-sketch-object) description))

(defun add-implementation (function-sketch-object implementation)
  (setf (implementations function-sketch-object) (cons implementation (implementations function-sketch-object))))

(defun intern-sketch (name &optional test-list description)
  (unless (find name *function-sketch-lib* :key 'name)
    (vector-push-extend (make-instance 'function-sketch :name name) *function-sketch-lib*)
    (when test-list (set-test-list (find name  *function-sketch-lib* :key 'name) test-list))
    (when description (set-description (find name  *function-sketch-lib* :key 'name) description))))

(defun challenge-me (&optional library-index)
  (cond   
    ((not (or (null library-index) (numberp library-index))) 
     (progn (princ "challenge-me didn't understand your library-index, choose new.") 
	    (return-from challenge-me (challenge-me (read)))))
    ((zerop (length *function-sketch-lib*)) (error "*function-sketch-lib* is empty."))
    ((null library-index) (return-from challenge-me (challenge-me (random (length *function-sketch-lib*)))))
    ((or (>= library-index (length *function-sketch-lib*)) (> 0 library-index)) 
     (progn (princ "Index out of bounds, choose new.") 
	    (return-from challenge-me (challenge-me (read))))))
  (let ((chosen-sketch (elt *function-sketch-lib* library-index)))
    (print chosen-sketch)
    (format t "~%Now write a function that fulfills the tests.~%")
    (let ((data (read)))
      (compare-to-sketch (eval data) chosen-sketch)
      (if *passed?*
	  (progn
	    (add-implementation chosen-sketch data)
	    (format t 
		    "Congratulations, your function passed all the tests!
It is now added in implementations-list of sketch object ~a.~%" 
		    (name chosen-sketch)))
	  (setf *passed?* t)))))


(intern-sketch 'add-two '(((1 1) . 2) ((1 2) . 3) ((0 0) . 0)) "Adds two arguments...")
(intern-sketch 'add-three '(((1 1 1) . 3) ((1 2 2) . 5) ((0 0 0) . 0)) "Adds three arguments...")
(intern-sketch 'return-two '(((1 1) . 2) ((1 2) . 2) ((0 0) . 2)) "Returns 2 no matter what the input...")
(intern-sketch 'return-three '(((1 1) . 3) ((1 2) . 3) ((0 0) . 3)) "Returns 3 no matter what the input...")
(intern-sketch 'my-last '((((1 2 3)) . (3)) (((a b c)) . (c)) (((1)) . (1))) "Extracts the last box from a list.")
(intern-sketch 'my-two-last '((((1 2 3)) . (2 3)) (((a b c)) . (b c)) (((1 0)) . (1 0))) 
	       "Extracts the two last boxes from a list.")
(intern-sketch 'my-kth-element '((((1 2 3) 2) . 3) (((a b c) 1) . b) (((1) 0) . 1)) 
	       "Extracts the k'th element from a list (zero based).")
(intern-sketch 'my-#-elements '((((1 2 3)) . 3) (((a b c d)) . 4) (((1)) . 1)) 
	       "Gives the number of elements in a list.")
(intern-sketch 'my-reverse '((((1 2 3)) . (3 2 1)) (((a b c d)) . (d c b a)) (((1)) . (1))) 
	       "Gives the reverse of a list.")
(intern-sketch 'my-palindrome? '((((1 2 3)) . nil) (((a b c d c b a)) . t) (((1)) . t)) 
	       "Returns T if list is a palindrome, nil otherwise.")
(intern-sketch 'my-flatten '((((1 (2 (3)))) . (1 2 3)) (((a (b c (d)) c (b a))) . (a b c d c b a)) ((((1))) . (1))) 
	       "Flattens nested list structure.")
(intern-sketch 'my-consecutive-duplicate-killer 
	       '((((a a a a b c c a a d e e e e)) . (a b c a d e)) 
		 (((1 0 0 1 1 1 0)) . (1 0 1 0))) 
	       "Replaces consecutive copies of element by single element. Conserves order of elements.")
(intern-sketch 'my-pack 
	       '((((a a a a b c c a a d e e e e)) . ((a a a a) (b) (c c) (a a) (d) (e e e e))) 
		 (((1 0 0 1 1 1 0)) . ((1) (0 0) (1 1 1) (0)))) 
	       "Packs consecutive duplicates of list elements into sublists.")
(intern-sketch 'my-encode
	       '((((a a a a b c c a a d e e e e)) . ((4 a) (1 b) (2 c) (2 a) (1 d) (4 e))) 
		 (((1 0 0 1 1 1 0)) . ((1 1) (2 0) (3 1) (1 0)))) 
	       "All elements are encoded as lists (N E) where N is # of consecutive repetitions 
of the element E. ")
(intern-sketch 'my-encode-duplicates 
	       '((((a a a a b c c a a d e e e e)) . ((4 a) b (2 c) (2 a) d (4 e))) 
		 (((1 0 0 1 1 1 0)) . (1 (2 0) (3 1) 0))) 
	       "Consecutive duplicates are encoded as lists (N E) where N 
is # of consecutive repetitions of element E. Single elements are left untouched.")
(intern-sketch 'my-unpack
	       '(((((4 a) (1 b) (2 c) (2 a) (1 d) (4 e))) . (a a a a b c c a a d e e e e)) 
		 ((((1 1) (2 0) (3 1) (1 0))) .  (1 0 0 1 1 1 0))) 
	       "Constructs a list from a packed list where consecutive repetitions are encoded as lists (N E) where N 
is # of consecutive repetitions of element E.")
(intern-sketch 'my-unpack-duplicates
	       '(((((4 a) b (2 c) (2 a) d (4 e))) . (a a a a b c c a a d e e e e)) 
		 (((1 (2 0) (3 1) 0)) .  (1 0 0 1 1 1 0))) 
	       "Constructs a list from a packed list where consecutive duplicates are encoded as lists (N E) where N 
is # of duplicates of element E. Single elements are left untouched.")
(intern-sketch 'my-duplicate
	       '((((1 2 3)) . (1 1 2 2 3 3)) (((a b c d)) . (a a b b c c d d)) (((1)) . (1 1))) 
	       "Duplicates the elements of a list.")
(intern-sketch 'my-replicate
	       '((((1 2 3) 3) . (1 1 1 2 2 2 3 3 3)) (((a b c d) 1) . (a b c d)) (((1) 5) . (1 1 1 1 1)))
	       "Replicates the elements of a list a given number of times.")
(intern-sketch 'my-nth-drop
	       '((((1 2 3 4 5 6) 3) . (1 2 4 5)) (((a b c d) 1) . ()) (((a b c d e f) 5) . (a b c d f)))
	       "Drops every N'th element from a list.")
(intern-sketch 'my-split
	       '((((1 2 3 4 5 6) 3) . ((1 2 3) (4 5 6))) 
		 (((a b c d) 1) . ((a) (b c d))) 
		 (((a b c d e f) 5) . ((a b c d e) (f))))
	       "Splits a list into two parts; the length of the first part is given.")
(intern-sketch 'my-slice
	       '((((1 2 3 4 5 6) 1 3) . (2 3)) 
		 (((a b c d) 0 1) . ()) 
		 (((a b c d e f) 5 6) . (f)))
	       "Extracts a slice from a list. (zero based. Including firstindex, upto but not including second index)")
(intern-sketch 'my-rotate
	       '((((1 2 3 4 5 6) 3) . (4 5 6 1 2 3)) 
		 (((a b c d) -1) . (d a b c)) 
		 (((a b c d e f) 1) . (b c d e f a)))
	       "Rotates a list N places to the left.")
(intern-sketch 'my-remove-kth
	       '((((1 2 3 4 5 6) 0) . (2 3 4 5 6)) 
		 (((a b c d) 2) . (a b d)) 
		 (((a b c d e f) -1) . (a b c d e)))
	       "Removes the K'th element from a list. Zero based. Should support negative indexes.")
(intern-sketch 'my-list-insert
	       '(((3 (1 2 3 4 5 6) 0) . (3 1 2 3 4 5 6)) 
		 ((Q (a b c d) 2) . (a b Q c d)) 
		 ((Q (a b c d e f) -1) . (a b c d e f Q)))
	       "Inserts an element at a given (zero based) position into a list.")
(intern-sketch 'my-range
	       '(((0 10) . (0 1 2 3 4 5 6 7 8 9)) 
		 ((1 -2) . (1 0 -1)) 
		 ((10 0) . (10 9 8 7 6 5 4 3 2 1)))
	       "Creates a list containing all integers within a given range. 
If first argument is smaller than second, produce a list in decreasing order.")

Code: Select all

(challenge-me)

Code: Select all

(challenge-me <index>)

Code: Select all

(loop for i from 0 to (1- (length *function-sketch-lib*)) do (challenge-me i))

Code: Select all

(implementations (find '<sketchname> *function-sketch-lib* :key 'name))

Code: Select all

*function-sketch-lib*

Code: Select all

(clear-sketch-lib)