A little program with twenty-six lisp problems

Discussion of Common Lisp

A little program with twenty-six lisp problems

Postby tobben » Mon Mar 19, 2012 12:49 pm

Hi all!

I'm pretty new, trying to learn lisp, so I decided to try to write a program than could teach me. Most ideas are copied from PCL and almost all problems are copied from http://www.ic.unicamp.br/~meidanis/courses/mc336/2006s2/funcional/L-99_Ninety-Nine_Lisp_Problems.html

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.")


Here's a little manual:

To get random challenge write:
Code: Select all
(challenge-me)


To get specific challenge write:
Code: Select all
(challenge-me <index>)


To get all challenges in a row write:
Code: Select all
(loop for i from 0 to (1- (length *function-sketch-lib*)) do (challenge-me i))


To extract earlier implementations (correct answers to challenges) of sketch named <sketchname> write:
Code: Select all
(implementations (find '<sketchname> *function-sketch-lib* :key 'name))


To view the whole library of function sketches write:
Code: Select all
*function-sketch-lib*


To empty the library write:
Code: Select all
(clear-sketch-lib)


To do other stuff, I guess reading the posted code is both faster and more rewarding than my explanations.

Feel free to post new sketches, implementations or comments on the code. I'm here to learn. :geek:
tobben
 
Posts: 2
Joined: Fri Jan 13, 2012 6:28 am

Return to Common Lisp

Who is online

Users browsing this forum: Google [Bot] and 3 guests

cron