Mathematical thinking and how to solve "lowest common ancestor"

It is quite possible on your interview to have questions related to (binary) trees. Here is one that I have on mine a year ago.

Given values of two nodes in a Binary Tree, write a c program to find the Lowest Common Ancestor (LCA).

The solution that I will present is not optimal, but did the job. Most interesting is how I found the solution using technique described in the book
Thinking Mathematically
On interview I implement it in Python but here I will use Common Lisp. Let's start time is up. Here is the scheme from the book that I follow:

ENTER

It is strange that representation is not given so the first question is: How to represent a tree in Common Lisp?

The easiest way is as nested list. For example:

(1 (2 (6 7)) (3) (4 (9 (12))) (5 (10 11)))

The first element of a list is the root of that tree (or a node) and the rest of the elements are the subtrees (every new open parenthesis is a next level of the tree). For example, the subtree (6 7) is a tree with 2 at its root and the elements 6 7 as its children. So I start digging on this.
Another representation that I found is to use Paul Graham "ANSI Common Lisp" representation:

(defstruct node
  elt (l nil) (r nil))

I usually create a lisp file and start codding, trying and testing. Sometime I receive strange errors.
As you know defstruct in Lisp also defines predicates e.g. node-p. It is possible to clash names easily. Word node is quite used when we talk for trees.
Doing this SBCL returns bizarre message:

caught WARNING:
  Derived type of TREE is
    (VALUES NODE &OPTIONAL),
  conflicting with its asserted type
    LIST.
  See also:
    The SBCL Manual, Node "Handling of Types"

REMEMBER

DO NOT forget to comment unused code!

Because I have binary tree may be a better way to represent it with nested lists is to use 'a-list' (more readable). For example:

(1 (2 (6 . 7)) (3) (4 (9 (12))) (5 (10 . 11))).

Even better - display empty:

(0 (1 (2 . 3) NIL) (4 (5 (6) NIL) NIL))

What is a node? (elm (left right))

This is not consistent - (left right) could not be treated as 'elm'. Let's fix it:

(0 (1 (2) (3)) (4 (5 (6))))

Great now I have the tree!

;; Format is ugly but more like a tree
(defparameter *bin-tree* '(0
                           (1
                            (2) (3))
                           (4
                            (5
                             (6)))))

GENERALIZE

(defun make-bin-leaf (elm)
  "Create a leaf."
  (list elm))

(defun make-bin-node (parent elm1 &optional elm2)
  (list parent elm1 elm2))

;; simple creation test
(deftest test-make-bin-tree ()
  (check
    (equal (make-bin-node 0 (make-bin-node 1 (make-bin-leaf 2)
                                           (make-bin-leaf 3))
                          (make-bin-node 4 (make-bin-node 5 (make-bin-leaf 6))))
           '(0 (1 (2) (3)) (4 (5 (6) NIL) NIL)) )))

INTRODUCE

Define what is node and leafs (not during the interview time is up)

(defun node-elm (node)
  (first node))

(defun node-left (node)
  (first (second node)))

(defun node-right (node)
  (first (third node)))

(deftest test-nodes ()
  (check
    (eq (node-left '(1 (2) (3))) 2)
    (eq (node-right '(1 (2) (3 (4) (5)))) 3)
    (eq (node-right 1) nil)
    (eq (node-elm '(1)) 1)
    (eq (node-elm nil) nil)))

;;; Predicates

(defun leaf-p (node)
  "Test if binary tree NODE is a leaf."
  (and (listp node)
       (= (list-length node) 1)))

(defun node-p (node)
  "Test if binary tree node is a node with children"
  (not (leaf-p node)))

;; wishful thinking ;) 
(defun member-p (elm tree)
  (eq (find-anywhere elm tree) elm))

AHA!

I discover that it very easy to write 'find-anywhere' when we present trees as nested lists this: (0 (1) (2)) 'car' is the current 'cdr's
are the successors and we stop when 'car' is an atom. There is no need to remember DFS.

(defun find-anywhere (item tree)
  "Does ITEM occur anywhere in TREE?
Returns searched element if found else nil."
  (if (atom tree)
      (if (eql item tree) tree)
      (or (find-anywhere item (first tree))
          (find-anywhere item (rest tree)))))

(deftest test-member-p ()
  (check
    (eq (member-p 6 *bin-tree*) t)))

Good job! (Cheer up yourself)

REMEMBER

Do not make big steps test carefully everything!

ATTACK

Now I have a tree and I can concentrate on solving the problem.

SIMPLIFY

From where to start? As a rule I start from easiest case - one root and two leafs. In this case task is easy. If (root (p) (q)) then 'root' is the parent.

INTRODUCE

1. Names for the searched leafs: 'p' and 'q'
2. Method signature: (defun lca (root p q) ...)

Concentrate on (elm (left) (right)) and because this is the simplest case apply rule for the rest. From my previous experience I know that binary
trees are recursive structure so recursion will pass perfectly. Of course be careful how to terminate.

Algorithm could be:
- find first in a left sub-tree
- find second in a right sub-tree
- compare to the searched 'p' and 'q'

STUCK

How to track context? I could find easily element but I have to know its parent. Some how context should be created.

Is it possible to use recursion to create context?
A tree is a collection of smaller trees up to a simple node. In the same way that a list is a collection of smaller list.
We reduce 'elm'(it is tricky to choose proper name could be e.g. 'tree-branch-node-leaf-nil') so it is possible to be node, leaf or null. Wait a minute...

AHA! I could build the recursive algorithm using possible 'elm' values:

(lca-rec nil 1 2)
                         (lca-rec '(1) 1 2)
                         (lca-rec '(0 (1) (2)) 1 2)

And I can even use them also for tests.

Concentrate on the small picture - only one node.

;; if elm is null or leaf
(defun lca-rec (elm p q)
  (cond ((null elm) nil)
        ((or (eq (car elm) p)
             (eq (car elm) q)) elm)
        ;...
        ))

More difficult part - if it is a node (elm (p) (q))

(defun lca-rec (elm p q)
  (cond ((null elm) nil)
        ((or (eq (car elm) p)
             (eq (car elm) q)) elm)
        (t (let ((left (cadr elm))      ; ***
                 (right (caddr elm)))   ; ***
             (when (and left right)     ; ***
                 (car elm))))))         ; ***

Now I have a tree - the same solution recursively and reduce 'elm'

(defun lca-rec (elm p q)
  (cond ((null elm) nil)
        ((or (eq (car elm) p)
             (eq (car elm) q)) elm)
        (t (let ((left (lca-rec (cadr elm) p q))     ; ***
                 (right (lca-rec (caddr elm) p q)))  ; ***
             (when (and left right)
               (car elm))))))

What we have after recursion?
After recursion we are finished with current 'segment' from the big picture.

Is it possible to discover nothing?
YES! Because with recursion we do not traverse the whole tree.

But elements could be on different levels so I somehow to pass trough recursive calls what is found. That is OK, what I return from recursion is passed to the next recursive step.

AHA!

Now the better question is when it fails? Only when one or none elements are found.
Should I return if only one element is found? YES!

REMEMBER. Look at the recursive procedure as simplest part of something big. Recursive call is the glue to the big picture.

In our case:

.. ((left (lca-rec (cadr elm) p q))
    (right (lca-rec (caddr elm) p q))) ...

finds only 'left' or 'right' of the current node it doesn't search the whole tree. It seems like - but it is not true. That's why I have to return what is fond in current 'node' and the recursion will pass it to the next level until
both are found or not. Finally we have:

(defun lca-rec (elm p q)
  (cond ((null elm) nil)
        ((or (eq (car elm) p)
             (eq (car elm) q)) elm)
        (t (let ((left (lca-rec (cadr elm) p q))
                 (right (lca-rec (caddr elm) p q)))
             (if (and left right) (car elm)
                 ;; return what is found until now and hope other will be found on next iteration
                 (or left right))))))        ;; ***

Done. It seems difficult at first but when practice a while solving such problems are fun.

SICP exercises that I did during reading (chapters 1 and 2)

#lang racket

;;________________________________________________________________
;;                                                 Simple helpers

(define (double x) (* 2 x))
(define (square x) (* x x))

;;________________________________________________________________
;;                                                        ex. 1.3

(define (sum-of-squares x y) (+ (square x) (square y))) 

(define (smallest x y z)
  (cond
    ((and (< x y) (< x z)) x)
    ((and (< y x) (< y z)) y)
    (else z)))

;; (smallest 5 2 1) ;; 1

(define (sum-of-squared-largest-two x y z) 
  (cond ((= (smallest x y z) x) (sum-of-squares y z)) 
        ((= (smallest x y z) y) (sum-of-squares x z)) 
        ((= (smallest x y z) z) (sum-of-squares x y)))) 

;; (sum-of-squared-largest-two 1 3 4) ;; 25
;; (sum-of-squared-largest-two 4 1 3) ;; 25
;; (sum-of-squared-largest-two 3 4 1) ;; 25

;;________________________________________________________________
;;                                                        ex. 1.6

;; Because new-if is a function, both of its parameters are evaluated before the operation is performed.
;; Since one of the parameters is a call to sqrt-iter, the first operation of which is a call to new-if,
;; an endless loop is formed and the function never completes.

;;________________________________________________________________
;;                                                       ex. 1.12

(define pascal
  (lambda (j n)
    (cond ((= j 0) 1)
          ((= j n) 1)
          (else
           (+ (pascal (- j 1) (- n 1)
                      (pascal j (- n 1))))))))

;;________________________________________________________________
;;                                                       ex. 1.42

(define (compose f g)
  (lambda (x) (f (g x))))

;; ((compose add1 add1) 2) ;; 4

;;________________________________________________________________
;;                                                       ex. 1.43

;; Use types as design guide.
;; [A -> A, number] -> (A -> A) (hint: A -> A indicates procedure)
(define (repeated proc n)
  (if (= n 0)
      (lambda (x) x)  ;; return whatever is passed!
      (lambda (x)     ;; return function
        (proc
         ((repeated proc (- n 1)) x)))))

;; ((repeated square 2) 5) ;; 625

;;________________________________________________________________
;;                                                        ex. 2.5

(define zero (lambda (f) (lambda (x) x)))

(define (add-1 n)
  (lambda (f) (lambda (x) (f ((n f) x)))))

;; (add-1 zero)

;;________________________________________________________________
;;                                                       ex. 2.17

(define (last-pair lst)
  (define (last-inner lst last)
    (if (null? lst)
      last
      (last-inner (cdr lst) (car lst))))
  (last-inner lst '()))

;; (last-pair '(1 2 3 4 8))

;;________________________________________________________________
;;                                                       ex. 2.18

(define (reverse items) 
  (if (null? items) 
      '() 
      (append (reverse (cdr items)) 
              (list (car items))))) 

;; (reverse '(1 2 3 4))

 
;;________________________________________________________________
;;                                                       ex. 2.23
  
(define (for-each proc items) 
  (cond ((not (null? items)) 
         (proc (car items)) 
         (for-each proc (cdr items))))) 

;; (for-each (lambda (x) (newline) (display x)) (list 1 2 3 4))

;;________________________________________________________________
;;                                                       ex. 2.27

(define (deep-reverse lst) 
  (cond ((null? lst) '()) 
        ((pair? (car lst)) 
         (append          ; it is a pair
          (deep-reverse (cdr lst)) (list (deep-reverse (car lst))))) 
        (else 
         (append          ; not a pair (the same as 'reverse' procedure)
          (deep-reverse (cdr lst)) (list (car lst)))))) 

;; (deep-reverse '((1 2) (3 4) 5 6 7))

;;________________________________________________________________
;;                                                       ex. 2.30

(define (square-tree tree)
  (cond
    ((null? tree) '())
    ((not (pair? tree)) (* tree tree))
    (else
     (cons (square-tree (car tree)) (square-tree (cdr tree))))))

;; (square-tree '(1 (2 (3 4) 5) (6 7)))

(define (square-tree2 tree)
  (map (lambda (sub-tree)
         (if (pair? sub-tree)
             (square-tree2 sub-tree) ;; common way to recure using map
             (* sub-tree sub-tree)))
   tree))

;; (square-tree2 '(1 (2 (3 4) 5) (6 7)))

;;________________________________________________________________
;;                                                       ex. 2.31

(define (tree-map proc tree)
    (cond
      ((null? tree) '())
      ((not (pair? tree)) (proc tree))
      (else
       (cons (tree-map proc (car tree))
             (tree-map proc (cdr tree))))))

(define (square-tree3 tree)
  (tree-map square tree))

;; (square-tree3 '(1 (2 (3 4) 5) (6 7)))

;;________________________________________________________________
;;                                                       ex. 2.32

#| Let's try to find out recursion.
Here are the 8 sets making up the power set (all possible subsets) of {1, 2, 3}. 

{ }, {1}, {2}, {3}, {1, 2}, {1, 3}, {2, 3}, {1, 2, 3}

They're topologically sorted from small to large, but this presentation doesn't illustrate
the inductive structure of power sets. This one does:

{ }, {2}, {3}, {2, 3}
{1}, {1, 2}, {1, 3}, {1, 2, 3}

Note the first of the two rows is the power set of {2, 3}. The second row is the power set
of {2, 3} all over again, except that a 1 has been included in each one. There's the
recursive structure for you: the power set of {1, 2, 3} is really two copies of {2, 3}'s
power set chained together, except that the second copy prepends a 1 onto the front of
each entry. Induction right?
|#

;; The power set of {} is {{}}. That's because the empty
;; set is a subset of itself.
;;
;; The power set of a non-empty set A with first element a is
;; equal to the concatenation of two sets:
;;     - the first set is the power set of A - {a}. This
;;       recursively gives us all those subsets of A that
;;       exclude a.
;;
;;     - the second set is once again the power set of A - {a},
;;       except that {a} has been prepended aka consed to the
;;       front of every subset.
;;
(define (subsets s)
  (if (null? s)
      (list '())   ;; we use 'append' so must be a list
      (let ((rest (subsets (cdr s))))
        (append rest 
                (map (lambda (x) (cons (car s) x)) rest)))))

;; (subsets '(1 2 3)) ;; '(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))

;;________________________________________________________________
;;                                                       ex. 2.33

(define (enumerate-interval low high)
  (if (> low high)
      '()
      (cons low (enumerate-interval (+ low 1) high))))

;; known also as 'fold-right'
(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

;; (accumulate + 0 '(1 2 3))
;; Hint: Accept 'initial' parameter as 'car part'
;;       Accept 'sequence' parameter as 'cdr part'

(define (a-map p sequence)
  (accumulate (lambda (x y) (cons (p x) y)) '() sequence))

;; (a-map double '(1 2 3))

(define (a-append seq1 seq2)
  (accumulate cons seq2 seq1))

;; (a-append '(1 2 3) '(4 5))

(define (a-lenght sequence)
  (accumulate (lambda (x y) (+ 1 y)) 0 sequence))
  
;; (a-lenght '(4 2 5))
;; (a-lenght '(4 2 5 9 11))

;;________________________________________________________________
;;                                                       ex. 2.35

(define (count-leaves x)
  (cond ((null? x) 0)
        ((not (pair? x)) 1)
        (else (+ (count-leaves (car x))
                 (count-leaves (cdr x))))))

;; (count-leaves '((1 2) 3 4))

(define (a-count-leaves t)
  (accumulate + 0 (map (lambda (x) 
                         (if (not (pair? x))
                             1
                             (a-count-leaves x)))
                       t)))

;; (a-count-leaves '((1 2) 3 4))

;;________________________________________________________________
;;                                                Nested Mappings

;; like two nested cycles
(define (all-pairs n)
  (accumulate append
              '()
              (map (lambda (i)
                     (map (lambda (j) (list i j))
                          (enumerate-interval 1 (- i 1))))
                   (enumerate-interval 1 n))))

;; (all-pairs 3) ;; ((2 1) (3 1) (3 2))

#|
How to think during development
-----------------------------------

If there are four elements in the original list, there are four elements in the final list
generated by any call to map. We can concatenate the four lists by applying append just
prior to exit. That means we have a partial implementation, and it looks like this:

                                            
(define (permutations items)
  (if (null? items) '(())
      (apply append
             (map function-to-be-determined items))))

This mapping function isn't exactly trivial. It needs to transform an isolated element into
a list of permutations, where every permutation in that list begins with said element. We
can write it as a lambda function, which recognizes that its incoming argument is the
element that needs to be at the front of all the permutations it generates. In order to
generate those permutations, it must remove the element from the list, recursively
generate all of its permutations, and then map over that list so it can cons the
distinguished element on to the front of each of its permutations. Let's write a
standalone lambda that assumes that items is in scope.

(lambda (element)
  (map another-function-to-be-determined (permutations (remove element items))))

(Racket provide function remove)
This inner mapping function is easier... it just needs to cons the incoming element to the
front of each permutation produced by the recursive permutations call. Assuming that
element is in scope, another-function-to-be-determined can be replaced by:

(lambda (permutation)
  (cons element permutation))

Now we put all of this together, to get one mean looking function. (There are dotted
lines surrounding the two lambda functions we wrote, so you have an easier time seeing
how far each one stretches.)
|#

(define (permutations items)
  (if (null? items) '(())       ;; do not forget when use 'append'
      (apply append
             (map (lambda (element)
                    (map (lambda (permutation)
                           (cons element permutation))
                         (permutations (remove element items))))
                  items))))

;; (permutations '(1 2 3)) ;; ((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))

;;________________________________________________________________
;;                                               Picture language

#|
* Data abstraction
  - Separate use of data structure from details of data structure
* Procedural abstraction
  - Capture common patterns of behavior and treat as black box for
    generating new patterns
* Means of combination that satisfy the closure property
  - Create complex combinations, then treat as primitives to support
    new combinations
* Use modularity of components to create new language for particular problem domain

What is a picture?
* Could just create a general procedure to draw collections of line segments
* But want to have flexibility of using any frame to draw in frame so we make a picture be a procedure!
* Captures the procedural abstraction of drawing data within a frame

(define (make-picture seglist)
  (lambda (rect)
    (for-each
     (lambda (segment)
       (let ((b (start-segment segment))
             (e (end-segment segment)))
         (draw-line rect
                    (xcor b)
                    (ycor b)
                    (xcor e)
                    (ycor e))))
     seglist)))

Critical idea about languages and programs design:
This is the approach of stratified design, the notion that a complex system should be structured
as a sequence of levels that are described using a sequence of languages. Each level is constructed
by combining parts that are regarded as primitive at that level, and the parts constructed
at each level are used as primitives at the next level. The language used at each level
of a stratified design has primitives, means of combination, and means of abstraction appropriate
to that level of detail. Stratified design pervades the engineering of complex systems.
|#

;;________________________________________________________________
;;                                                       ex. 2.59

(define (element-of-set? x set)
  (cond ((null? set) false)
        ((equal? x (car set)) true)
        (else (element-of-set? x (cdr set)))))

(define (union-set set1 set2)
  (cond
    ((null? set1) set2) ;; no need to check set2 for null - basic recursion is on set1
    ((element-of-set? (car set1) set2) (union-set (cdr set1) set2))
    (else
     (cons (car set1) (union-set (cdr set1) set2)))))
                       
                       
(define set1 '(1 2 3 4))
(define set2 '(4 5 6))

;; (union-set set1 set2)

;;________________________________________________________________
;;                                                       ex. 2.76

; a. Generic operations with explicit dispatch
; New operations - Requires defining new procedures that explicitly dispatch
; a different procedure for each type.
; New types - Requires adding a new clause in all the existing generic procedures.
;
; b. Data-directed style
; New operations - For each type already present, a new procedure that performs
; the new operation for data belonging to that type should
; be defined and added to the table using put.
; (Adding a new row to the table).
; New types - Operations should be defined for the new type and should be
; added to the table using put. (Adding a new column to the table).
;
; c. Message passing style
; New operations - Each data object already defined should be modified to include
; a clause that dispatches on the new operation.
; New types - Requires adding a new data object that returns a procedure and takes
; into account all the existing operations.
;
; For a system in which new operations are added often, data-directed style is more appropriate.
; For a system that adds new types often, message passing style is more appropriate.

За една задача от ФМИ (част 2)

В първа част описах как разсъждавм докато решавам една задача от ФМИ. Всичко стана много стихийно, така че крайния резултат макар и да дава верни резултати не ме удовлетвори. "Моя човек" си взе изпита между другото, макар и да му се наложило да дава сложни обяснения, защо не е решил задачата :)

Пита се къде е грешката?

;; nothing to change
(define count-trace
  (lambda (a lat)
    (cond
      ((null? lat) 0)
      ((eq? a (car lat)) (+ 1 (count-trace a (cdr lat))))
      (else
       (count-trace a (cdr lat))))))

(define reduce
  (lambda (a lat)
    (cond
      ((null? lat) '())
      ((eq? (car lat) a) (reduce a (cdr lat)))
      (else
       (cons (car lat) (reduce a (cdr lat)))))))

(define revert
  (lambda (lst)
    (define revert-in
      (lambda (lat rev)
        (cond
          ((null? lat) rev)
          (else
           (revert-in (cdr lat) (cons (car lat) rev))))))
    (revert-in lst '())))

(define freq-*
  (lambda (lst func)
    (let freq-in ((lat lst ) (seen '()))
      (cond
        ((null? lat) seen)
        (else
         (let ((curr (car lat)))
           (revert (freq-in (reduce curr lat)
                            (cons (cons (func curr lat) curr) seen)))))))))

(define count-freq
  (lambda (lat)
    (freq-* lat count-trace)))
 
;; (count-freq '(a a b c)) ;; '((2 . a) (1 . b) (1 . c))

В Lisp ако не познаваш добре специалните форми и не знаеш API-то много лесно да предефинираме някои от тях. Когато някой пише на Lisp той обикновено знае няколко диалекта - Scheme, Common Lisp или Clojure и съответно пренася своите знания. Ето защо никога не би използвал името 'reduce' за име на функция, която маха елемент от лист. За справка ето какво прави reduce в Common Lisp:

(reduce #'* '(1 2 3 4 5)) =>  120

Редуцира списъка като прилага съответна функция. Затова правилното име е remove и спазвам същата сигнатура на параметрите

(define (remove elm ls)
  (cond
    ((null? ls) '())
    ((equal? (car ls) elm) (remove elm  (cdr ls)))
    (else
     (cons (car ls) (remove elm (cdr ls))))))

Това до тук е малък проблем. Защо се налага да пиша 'revert'?! Името не е ли по добре да е 'revers'?

(define (reverse seq)
  (if (null? seq)
      '()
      (cons (reverse (cdr seq)) (car seq))))

(reverse '(4 3 2 1)) ;; '((((() . 4) . 3) . 2) . 1)

'reverse' определено е много по-добре и другото е, че повлиян от 'Little Schemer' използвам във всички ситуации cond. Не е нужно. Иначе разсъжденията ми са правилни:

Поставам (2 3 4) пред 1. Поставям (3 4) пред (2 1). Поставям 4 пред (3 2 1).
Забелязах, че винаги вземам cdr като първи параметър и оставям втория да формира списъка - обединявам с cons.

Грешка е, че не съм го приложил правилно. Поставам (2 3 4) пред 1 .... Поставям (3 4)... .
Поставям, поставям .... значи рекурсия и най-накрая обединявам с cons т.е

(cons (reverse (cdr seq)) (car seq))))

е много по-правилно отколкото:

(revert-in (cdr lat) (cons (car lat) rev))

Да, ама кой да внимава! Да ме пита човек защо поставям рекурсивното извикване най-отпред. Резултата '((((() . 4) . 3) . 2) . 1) не е чак толкова обезкуражаващ. По грешен начин конкатенирам.

(define (reverse items) 
   (if (null? items) 
       '() 
       (append (reverse (cdr items)) 
               (list (car items)))))

(reverse '(1 2 3 4)) ;; (4 3 2 1)

Тука хитрината е: (list (car items)). append приема два листа затова 4 го представяме като (4) и append се превръща в агрегатор. Много често се използва.

Нещо подобно се случва и с freq-*. Пак решението е било пред мен ама съм го изпуснал. Ето какво съм предложил за алгоритъм:
Вземам първия атом и броя колко пъти се среща, записвам и редуцирам списъка като махам този атом.

Това не е много "подходящо" за рекурсия или поне не е много интуитивно. Винаги трябва да има базов случай и после рекурсия. Правилното е:
Вземам първия атом и броя колко пъти се среща и записвам резултата, повтарям за редуцирания списък

1. Вземам първия атом и броя колко пъти се среща

;; PARTIAL: only once
(define (trace-first seq)
  (list (car seq) (count-trace (car seq) seq)))

(trace-first '(a b c a)) ;; '(a 2)

2. Повтарям за редуцирания списък
"Повтарям" ни подсказва рекурсия, следователно:

(define (trace-all seq)
  (if (null? seq)
      '()
      (cons (trace-first seq) (trace-all (remove (car seq) seq)))))

(trace-all '(a a a c b e f c f g t t w w w w w g h)) ;;  '((a 3) (c 2) (b 1) (e 1) (f 2) (g 2) (t 2) (w 5) (h 1))

Може да не повярвате, но това е всичко. Следва малко шлифоване:

(define (trace-all seq)
  (letrec
      ((T (lambda (a lat)
            (cond
              ((null? lat) 0)
              ((eq? a (car lat)) (+ 1 (T a (cdr lat))))
              (else
               (T a (cdr lat)))))))
       (if (null? seq)
           '()
           (let ((first (car seq)))
             (cons (list first (T first seq))
                   (trace-all (remove first seq)))))))

(trace-all '(a a a c b e f c f g t t w w w w w g h)) ;;

и още малко за краен резултат:

(define (remove elm ls)
  (cond
    ((null? ls) '())
    ((equal? (car ls) elm) (remove elm (cdr ls)))
    (else
     (cons (car ls) (remove elm (cdr ls))))))
 
(define (freq-* seq func)
  (letrec
      ((T (lambda (a lat)
            (cond
              ((null? lat) 0)
              ((eq? a (car lat)) (+ 1 (T a (cdr lat))))
              (else
               (T a (cdr lat)))))))
       (if (null? seq)
           '()
           (let ((first (car seq)))
             (cons (list first (T first seq))
                   (freq-* (func first seq) func))))))
 
(define (freq-remove seq)
  (freq-* seq remove))
 
(freq-remove '(a a a c b e f c f g t t w w w w w g h)) ;; '((a 3) (c 2) (b 1) (e 1) (f 2) (g 2) (t 2) (w 5) (h 1))

Решението вече е много по-чисто и профисионално. 'remove' е допостимо да бъде отделна функция, вероятно ще се ползва и от други. С 'count-trace' нещата са различни, тя е помощна и твърде специализирана, за да я оставяме независима. Използвам правилото от "Seasoned Schemer":

.----------------------------------------------------------------------------.
| The thirteenth commandment                                                 |
|                                                                            |
| Use (letrec ...) to hide and to protect functions.                         |
'----------------------------------------------------------------------------'

С това мисля да сложа край на задачата. Получи се доста добър Scheme код. Ето и колекция от лекции, които са доста полезни. За Scheme гледайте от 19-23 включително. Ще разберете колко са важни 'map' и 'apply'. Ето един пример от там:

;;
;; Function: flatten-list
;; ----------------------
;; Flattens a list just like the original flatten does, but
;; it uses map, apply, and append instead of exposed car-cdr recursion.
;;
(define (flatten-list ls)
  (cond ((null? ls) '())
        ((not (list? ls)) (list ls))
        (else (apply append (map flatten-list ls)))))

(flatten-list '(1 2 (3) 4)) ;; (1 2 3 4)

Сложно е нали?

За една задача от ФМИ

Преди два месеца ме помолиха да помгна с една задача, дадена на изпит по функционално програмиране. Ето горе-долу как изглеждаше тя:

Да се напише програма на Scheme, която да пресмята честотата на атомите в даден лист. Пример:
Вход: '(a a b c)
Изход: '((2 a) (1 b) (1 c))


Да си призная тогава отказах, защото решението трябваше да се достави в рамките на 2 часа, а аз бях несигурен. Не бях писал на Scheme поне от 4 години. Но си е предизвикателсвто, та реших да си припомня. Чел съм две книги по-темата: How to Design Programs и другата е The Little Schemer (цитатите в карето са от тази книга).

Аз ползвам Emacs за всичко освен за Java, така че беше логично да търся начин да го настроя за Scheme. Няма много избор, така че бързо си настроих Geiser. Нещата не потръгнаха, защото много неща съм забравил и се наложи да правя debug. Не става, така че на помощ идва DrRacket. Много добре, само дето не можах да му настроя key shortcuts да бъдат като на Emacs и се лиших от paredit.

Да си кажа честно не се справих в рамките на два часа със задачата. Ето и стъпките премесени с елементи на расъждение...
Реших да загрея пък и да си тествам средата като си поставих следната задача:

Да се провери дали даден атом принадлежи на даден списък. Пример:
Вход: 'a '(a b c))
Изход: #t


Не беше трудно

(define in-trace?
  (lambda (a lat)
    (cond
      ((null? lat) #f)
      ((eq? a (car lat)) #t)
      (else
       (in-trace? a (cdr lat))))))

;; (in-trace? 'a '(a b c)) ;; #t

Забележка: (define (in-trace? a lat)... е syntactic sugar на
(define in-trace? (lambda (a lat)....

The law of car:  The primitive car is defined only for non-empty lists.

The law of cdr:  The primitive cdr is defined only for non-empty lists.
                       The cdr of any non-empty list is always another list.

Scheme style:  Affix a question mark to the end of a name for a procedure whose
                      purpose is to ask a question of an object and to yield a boolean answer.
(Pronounce the question mark as if it were the isolated letter 'p'. For example, to read the fragment (PAIR? OBJECT) aloud, say: 'pair-pee object.')

Най-важното, което също подцених е самия алгоритъм, по който ще работя. Не го проиграх с лист и химикал, а писах хаотично. Притеснявах се за знанията си по Scheme, исках всичко да е много cool, исках да се докажа - това ме забави.

.----------------------------------------------------------------------------.
| The sixth commandment                                                      |
|                                                                            |
| Simplify (make it cool) only after the function is correct.                |
'----------------------------------------------------------------------------'

Алгоритъма, на който се спрях е следния:
Вземам първия атом и броя колко пъти се среща, записвам и редуцирам списъка като махам този атом. Пример:

(a a b c c) -> (2 a)
(b c c)     -> (1 b)
(c c)       -> (2 c)

Бързо се справих и извадих поуки:

(define count-trace
  (lambda (a lat)
    (cond
      ((null? lat) 0)
      ((eq? a (car lat)) (+ 1 (count-trace a (cdr lat))))
      (else
       (count-trace a (cdr lat))))))
;; (count-trace 'a '(a b a a a a c)) ;; 5

.----------------------------------------------------------------------------.
| The fourth commandment: (preliminary version)                              |
|                                                                            |
| Always change at least one argument while recurring. It must be changed to |
| be closer to termination. The changing argument must be tested in the      |
| termination condition: when using cdr, test the termination with null?.    |
'----------------------------------------------------------------------------'

Рекурсията си я представям като спирала, която първоначално се навива за да дойде момента, в който проверката ((null? lat) 0) ще я спре. Тогава почва да се развива и функцията ще върне последния ред от тази спирала(функция) - там траява да се формира решението.

.----------------------------------------------------------------------------.
| The first commandment (final version)                                      |
|                                                                            |
| When recurring on a list of atoms, lat, ask two questions about it:        |
| (null? lat) and else.                                                      |
| When recurring on a number, n, ask two questions about it: (zero? n) and   |
| else.                                                                      |
| When recurring on a list of S-expressions, l, ask three questions about    |
| it: (null? l), (atom? (car l)), and else.                                  |
'----------------------------------------------------------------------------'

Следващата стъпка е да направя редуцирания списък:

(define reduce
  (lambda (a lat)
    (cond
      ((null? lat) '())
      (else (cond
              ((eq? (car lat) a) (reduce a (cdr lat)))
              (else (cons (car lat) (reduce a (cdr lat)))))))))

   
;; (reduce 'a '(a b c a)) ;; '(b c)

Задавали ли сте си въпроса какво ще стане ако имаме условие в else и то не мине? Резултат не е предвидим! Затова else не трябва да пропада.
Както в Common Lisp (cond ....(else... може да се напише и така (cond ....(#t...

Веднага рефакторирам - всички проверки минават над else всичко друго остава:

(define reduce
  (lambda (a lat)
    (cond
      ((null? lat) '())
      ((eq? (car lat) a) (reduce a (cdr lat)))
      (else 
       (cons (car lat) (reduce a (cdr lat)))))))

;; (reduce 'a '(a b c a)) ;; '(b c)

Тук са три много важни правила:

.----------------------------------------------------------------------------.
| The second commandment:                                                    |
|                                                                            |
| Use cons to build lists.                                                   |
'----------------------------------------------------------------------------'

Когато четох за първи път една книга за Lisp си мислех, че cons е много лесно нещо, но се оказа, че не съм съвсем прав.
Ако си мислите и вие така, тогава защо:

> (cons '(1 2) '(3 4))
((1 2) 3 4)

Hint: How this is represented in memory?

.----------------------------------------------------------------------------.
| Golden rule of cons:                                                       |
| The second argument to cons should be a list, and every list is ended by   |
| '()                                                                        |
'----------------------------------------------------------------------------'

Ето и някои обяснения, които смятам че са полезни:
cons build pairs, not lists! Lisp interpreters uses a 'dot' to visually separate the elements in the pair. car and cdr respectively return the first and second elements of a pair.

Lists are built on top of pairs. If the cdr of a pair points to another pair, that sequence is treated as a list.
The cdr of the last pair will point to a special object called null (represented by '()) and this tells the interpreter that it has reached the end of the list.
For example, the list '(a b c) is constructed by evaluating the following expression:

(cons 'a (cons 'b (cons 'c '())))
(a b c)

The list procedure provides a shortcut for creating lists:

(list 'a 'b 'c)
(a b c)

Another way to think of sequences whose elements are sequences is as trees.
The elements of the sequence are the branches of the tree, and elements that are themselves sequences are subtrees.

.----------------------------------------------------------------------------.
| The third commandment:                                                     |
|                                                                            |
| When building lists, describe the first typical element, and then cons it  |
| onto the natural recursion.                                                |
'----------------------------------------------------------------------------'

Пояснения за последното.

(else (cons (car lat) (reduce a (cdr lat))))
            |_______| |___________________|
             typical    natural recursion (recur on the rest of lat)

Хей, май сме готови?

(define freq
  (lambda (lst)
    (define freq-in
      (lambda (lat seen)
        (cond
          ((null? lat) seen)
          (else
           (freq-in (reduce (car lat) lat)
                     (cons (cons (count-trace (car lat) lat) (car lat)) seen))))))
    (freq-in lst '())))

;; (freq '(a a a c b e f c f g t t w w w w w g h))
;; '((1 . h) (5 . w) (2 . t) (2 . g) (2 . f) (1 . e) (1 . b) (2 . c) (3 . a))

Използвам closure функция, за да премахна паразитните параметри. Not bad, dude? Може би забелязвате проблема с изхода? Подреждам символите в обратен ред - това си е доста често срещан проблем в Lisp.

(define revert
  (lambda (lst)
    (define revert-in
      (lambda (lat rev)
        (cond
          ((null? lat) rev)
          (else
           (revert-in (cdr lat) (cons (car lat) rev))))))
    (revert-in lst '())))

;; (revert '(a b c)) ;; '(c b a)
;; (revert '((1 1) (2 2) (3 3))) ;; '((3 3) (2 2) (1 1))

Не я написах бързо. Но ето как разсъждавах:
Ще използвам рекурсия - значи ще трябва да редуцирам проблема с обръщането на (1 2 3 4) като използвам car и cdr.
Поставам (2 3 4) пред 1. Поставям (3 4) пред (2 1). Поставям 4 пред (3 2 1).
Забелязах, че винаги вземам cdr като първи параметър и оставям втория да формира списъка - обединявам с cons.

Може би ще намерите за по-подходящо следния метод - да разпишете рекурсията.
Примера е от "The Little Schemer":

;; The rember function removes the first occurrence
;; of the given atom from the given list.
(define rember
  (lambda (a lat)
    (cond
      ((null? lat) '())
      ((eq? (car lat) a) (cdr lat))
      (else (cons (car lat)
                  (rember a (cdr lat)))))))

;; (rember 'cup '(coffee mock cup tea cup hick)) ; '(coffee mock tea cup hick)

Най-труден е ред: ((eq? (car lat) a) (cdr lat)). Как да се съобрази съставянето на списъка?

(rember 'cup '(coffee mock cup tea hick))=
= (cons 'coffee (rember 'cup '(mock cup tea hick)))=
= (cons 'coffee (cons 'mock (rember 'cup '(cup tea hick)))= we hit ((eq? ...)
                                               |_______|
                                          (cdr '(cup tea hick)) and result is ready

С добро съмочувствие написвам и крайното решение като използам правилото:

.----------------------------------------------------------------------------.
| The eighth commandment                                                     |
|                                                                            |
| Use help functions to abstract from representations.                       |
'----------------------------------------------------------------------------'

(define freq-final
  (lambda (lst)
    (define freq-in
      (lambda (lat seen)
        (cond
          ((null? lat) seen)
          (else
           (revert
            (freq-in (reduce (car lat) lat)
                     (cons (cons (count-trace (car lat) lat) (car lat)) seen)))))))
    (freq-in lst '())))

;; (freq-final '(a a a c b e f c f g t t w w w w w g h))
;; '((3 . a) (2 . c) (1 . b) (1 . e) (2 . f) (2 . g) (2 . t) (5 . w) (1 . h))

;; (freq-final '(a a b c))
;; '((2 . a) (1 . b) (1 . c))

;; (freq-final '()) ;; '()

Като решение за задача на изпит е достатъчно. Въпроса е дали не можем да направим нещо допълнително. Трябва да помисля!

Това count-trace обвързващо така да се каже. Може да исаме нещо от рода на count-odd-trace.
Правя промените:

(define freq-*
  (lambda (lst func)
    (define freq-in
      (lambda (lat seen)
        (cond
          ((null? lat) seen)
          (else 
           (revert 
            (freq-in (reduce (car lat) lat) 
                     (cons (cons (func (car lat) lat) (car lat))
                           seen)))))))
    (freq-in lst '())))

;; (freq-* '(a a b c) count-trace) ;; '((2 . a) (1 . b) (1 . c))

.----------------------------------------------------------------------------.
| The ninth commandment                                                      |
|                                                                            |
| Abstract common patterns with a new function.                              |
'----------------------------------------------------------------------------'

From Lambda Calculus: One thing we do know how to do is: We know how to get rid of free variables.

Think about it: Why is x free in (lambda (y) x)? Because it doesn’t look like this: (lambda (x) (lambda (y) x)). Well, if we want it to look like that, let’s just make it be that! After all, we’re not changing the value of the expression, we’re only changing the way the free variable will derive its meaning:

We’re promising to pass in the value rather than rely on the rules of lexical scoping to ascribe the right value from the static (lexically apparent) context. This process of factoring out free variables is called abstraction.

Update: След като прочетох "Seasoned Schemer", видях че е удобно да използвам let конструкцията, за да премахна повтарящите се конструкции и това "паразитно" викане на помощната функция:

(define freq-*
  (lambda (lst func)
    (let freq-in ((lat lst ) (seen '()))
      (cond
        ((null? lat) seen)
        (else 
         (let ((curr (car lat)))
           (revert (freq-in (reduce curr lat) 
                            (cons (cons (func curr lat) curr) seen)))))))))

.----------------------------------------------------------------------------.
| The fifteenth commandment (revised version)                                |
|                                                                            |
| Use (let ...) to name the values of repeated expressions in a function     |
| definition if they may be evaluated twice for one and the same use of the  |
| function.                                                                  |
'----------------------------------------------------------------------------'

Имайки тази абстракция много лесно мога да напиша нейни производини:

(define count-freq
  (lambda (lat)
    (freq-* lat count-trace)))

;; (count-freq '(a a b c)) ;; '((2 . a) (1 . b) (1 . c))

Дали сме за шестица? Да - ако алгоритъма, който съм избрал е правилен и с не много голяма сложност. Правилото за оценка е:

The asymptotic outlook:  Ask not which takes longer, but rather which is more rapidly taking longer as the problem size increases.

Гледам крайния резултат и не ми харесва. Написана е с лутане, макар и да е правилна. Никой Lisp програмист не би я написал по този начин. Няма ситил, просто сбор от правила. Във втора част са поправките.

Advanced Emacs Commands

Common default Emacs key prefixes
Key prefix      Description
C-c             Commands particular to the current editing mode
C-x             Commands for files and buffers
C-h             Help commands
M-x             Literal function name
C-h b           Show key bindings

Emacs window-manipulation commands
Key               Function                   Description
C-x 4 f           find-file-other-window     Open a new file in a new buffer, drawing it in a new vertical
                                             window.

undefined         scroll-all-mode            Toggle the scroll-all minor mode. When it's on, all windows
                                             displaying the buffer in the current window are scrolled 
                                             simultaneously and in equal, relative amounts.

C-x 3    split-window-horizontally           Split the current window in half down the middle, stacking the new
                                             buffers horizontally.

undefined         follow-mode                Toggle follow, a minor mode. When it's on in a buffer, all windows
                                             displaying the buffer are connected into a large virtual window.

C-x ^             enlarge-window             Make the current window taller by a line; preceded by a negative,
                                             this makes the current window shorter by a line.

C-x }   shrink-window-horizontally           Make the current active window thinner by a single column.

C-x {   enlarge-window-horizontally          Make the current active window wider by a single column.

C-x -   shrink-window-if-larger-than-buffer  Reduce the current active window to the smallest possible size for
                                             the buffer it contains.

C-x +            balance-windows             Balance the size of all windows, making them approximately equal.

undefined        compare-windows             Compare the current window with the next window, beginning with
                                             point in both windows and moving point in both buffers to the
                                             first character that differs until reaching the end of the buffer.

Emacs text manipulation commands
Key              Function                    Description
C-x Tab          indent-rigidly              This command indents lines in the region (or at point).

undefined        fill-region                 This command fills all paragraphs in the region.

M-q              fill-paragraph              This command fills the single paragraph at point.

M-\              delete-horizontal-space     This command removes any horizontal space to the right and left of
                                             point.

C-o              open-line                   This command opens a new line of vertical space below point,
                                             without moving point.

C-t              transpose-chars             This command transposes the single characters to the right and
                                             left of point.

M-t              transpose-words             This command transposes the single words to the right and left of 
                                             point.

C-x C-t          transpose-lines             This command transposes the line at point with the line before it.

M-^              delete-indentation          This command joins the line at point with the previous line.
Preface with C-1 to join the line at point with the next line (C-1 M-^)

M-u              uppercase-word              This command converts the text at point to the end of the word to
                                             uppercase letters.

M-l              downcase-word               This command converts the text at point to the end of the word to 
                                             lowercase letters.

C-x C-l          downcase-region             This command converts the region to lowercase letters.

C-x C-u          upcase-region               This command converts the region to uppercase letters.

M-m              back-to-indentation         This command, given anywhere on a line, positions point at the 
                                             first non blank character on the line. 

C-s C-w                                      This command, add the (rest of the) word at the pointer for search

Emacs commands for using registers
Emacs registers are general-purpose storage mechanisms that can store one of many things, including text,
a rectangle, a position in a buffer, or some other value or setting. Every register has a label, which is
a single character that you use to reference it.

A register can be redefined, but it can contain only one thing at a time. Once you exit Emacs, all registers
are cleared.

Key               Function                   Description
C-x r space X     point-to-register          Save point to register named X.

C-x r s X         copy-to-register           Save the region to register named X.

C-x r r X         copy-rectangle-to-register Save the selected rectangle to register named X.

undefined         view-register              View the contents of a given register.

C-x r j X         jump-to-register           Move point to the location given in register named X.

C-x r i X         insert-register            Insert the contents of register named X at point.

Emacs commands for using bookmarks
Emacs has another facility for saving positions in buffers. These Emacs bookmarks work the same as registers,
but their labels can be longer than a single character, and they're more permanent: If you save them, you 
can use them between sessions. They persist until you remove them. As their name implies, bookmarks are 
handy for saving your position in a buffer so that you can return to it at a later time, most often during a 
later Emacs session.

Key               Function                   Description
C-x r m Bookmark  bookmark-set               Set a bookmark named Bookmark.

C-x r l           bookmarks-bmenu-list       List all saved bookmarks.

undefined         bookmark-delete            Delete a bookmark.

C-x r b Bookmark  bookmark-jump              Jump to the location set in the bookmark named Bookmark.

undefined         bookmark-save              Save all bookmarks to the bookmark file, ~/.emacs.bmk.
                                             (you can redefine it)

Emacs commands for using rectangles
Did you ever wish you could select a box of text from a document for copying, killing, or yanking purposes?
You can. In Emacs, a selection of text specified by any two opposite of its four corners is called a rectangle.

Key               Function                   Description
C-space           set-mark-command           Marks one corner of a rectangle (point marks the opposite corner).

C-x r k           kill-rectangle             Kills the current rectangle and saves it in a special rectangle 
                                             buffer.

C-x r d           delete-rectangle           Deletes the current rectangle and doesn't save it for yanking.

C-x r c           clear-rectangle            Clears the current rectangle, replacing the entire 
                                             area with whitespace.

C-x r o           open-rectangle             Opens the current rectangle, filling the entire area with 
                                             whitespace  and moving all text from the rectangle to the right.

C-x r M-w                                    Copy text without deleting the text from the buffer.

C-x r y           yank-rectangle             Yanks the contents of the last-killed rectangle at point, moving 
                                             all existing text to the right.

Mark rings
You should never have to scroll around randomly in a buffer to find "that place you were just looking at". 
Whenever you take a diversion (e.g. by searching, or pressing M-<  or M->), Emacs uses the mark to save 
your previous position, kind of like sticking your finger behind one page of a book while you go to glance at 
another page. You can return to the mark with C-x C-x.

However, Emacs saves up to 16 previous values of the mark, and you can jump to previous ones with C-u C-SPC. 
This makes mark and the mark ring a valuable navigation tool. You can use it somewhat mindlessly:
if you ever find yourself asking "where was I just now?" you can often just press C-u C-SPC until you
find yourself back in the right place.
  
Programming
Key                 Function                   Description
M-x                 check-parens               Checking for unmatched parentheses
C-x w h REGEXP FACE                            Highlight matches of pattern REGEXP in current buffer with FACE.

C-x w p PHRASE FACE                            Highlight matches of phrase PHRASE in current buffer with FACE.
                                               (PHRASE can be any REGEXP, but spaces will be replaced by matches
                                               to whitespace and initial lower-case letters will become case 
                                               insensitive.)

C-x w l REGEXP FACE                            Highlight lines containing matches of REGEXP in current buffer 
                                               with FACE.

C-x w r REGEX                                  Remove highlighting on matches of REGEXP in current buffer


Tips:
C-SPC                                          Make mark in some place and then disable it with C-g
                                               Go somewhere else and do it again and again etc.
C-u C-SPC                                      Back to previous mark, and back and back etc.
M-x re-builder                                 Helps you to create needed regular expression.

Highlighting Regexps, Phrases, And Lines
Key        Function                          Description
M-s h p    highlight-phrase                  It will ask you for a phrase and highlighting color and then highlight
                                             all the matching phrases in the buffer.
M-s h r    highlight-regexp                  Highlight anything that matches an arbitrary regexp
M-s h l    highlight-lines-matching-regexp   Highlights the entire line that contains the match to the regular expression
M-s h u    unhighlight-regexp                Un-highlight the matches


Useful references:
Emacs Tutorial
Beyond Emacs Tutorial
Reference Card

Lisp environment

Update: This environment evaluate to this - Pecan Emacs

Средата за разработка е била винаги важна и затова доста си играя с настройките. Все искам кода да е добре подреден, да имам лесен начин да достъпвам документацията, да има code completion и разни други глезотийки. Така и стана с Lisp средата за разработка. Просто задължителните неща са: SBCL, Linux и Emacs. Въпроса е как ще напаснем тези три неща и колко бързо ще свикнем с Emacs.
Аз използвам Debian и нещата, които се инсталират допълнително са:

sudo aptitude install sbcl
sudo aptitude install w3
sudo aptitude install w3-el-e21
sudo aptitude install hyperspec
sudo aptitude install emacs-goodies-el

Другото "важно" е да се смени клавишната комбинация за превключване от/към кирилица. В emacs "alt-shift" e много застъпена, така че "alt-alt"(Gnome default) или "ctrl-ctrl" e за предпочитане.
Аз не обичам много да пиша така,че искам да използвам и history-то на REPL-a. Както в моя shell. Като изплзвам стрелките да виждам какво е било. Затова инсталирам linedit:

> sbcl
* (require :asdf-install)
* (asdf-install:install :linedit)   ;first-time installation only

* (require :linedit)                ;if already installed
* (linedit:install-repl) 

Готови ли сте и за моя dot.emacs:

;;; Can use now Common Lisp functions                                                                                                                                                                
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                                                                                                                                                             

(require 'cl)                                                                                                                                                                                        

;;; Art                                                                                                                                                                                              
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                                                                                                                                                             

(set-background-color "black")                                                                                                                                                                       
(set-face-background 'default "black")                                                                                                                                                               
(set-face-background 'region "black")                                                                                                                                                                
(set-face-foreground 'default "white")                                                                                                                                                               
(set-face-foreground 'region "gray60")                                                                                                                                                               
(set-foreground-color "white")                                                                                                                                                                       
(set-cursor-color "red")                                                                                                                                                                             

;;; System settinngs                                                                                                                                                                                 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                                                                                                                                                             

;; Misc customizations                                                                                                                                                                               
(setq inhibit-startup-message t)        ;no splash screen                                                                                                                                            

(auto-compression-mode t)               ;turn on auto file uncompression                                                                                                                             

(menu-bar-mode 0)                       ;turn off unused UI                                                                                                                                          

(setq tab-width 4)                      ;tab size                                                                                                                                                    

(setq display-time-24hr-format t)       ;display the current time                                                                                                                                    
(display-time)                                                                                                                                                                                       

(global-font-lock-mode t)               ;colorize all buffers                                                                                                                                        
(setq font-lock-maximum-decoration t)                                                                                                                                                                

(show-paren-mode t)                     ;highlight parens                                                                                                                                            
(defconst query-replace-highlight t)    ;highlight during query                                                                                                                                      
(defconst search-highlight t)           ;highlight incremental search                                                                                                                                
(transient-mark-mode t)                 ;higlight the marked region (C-SPC)                                                                                                                          

;; Some useful key bindings                                                                                                                                                                          
(global-set-key [home] 'beginning-of-line)                                                                                                                                                           
(global-set-key [end] 'end-of-line)                                                                                                                                                                  

;; Column & line numbers in mode bar                                                                                                                                                                 
(column-number-mode t)                                                                                                                                                                               
(line-number-mode t)                                                                                                                                                                                 

(setq frame-title-format "%b")          ;set title to buffer name                                                                                                                                    

;; Ediff customizations                                                                                                                                                                              
(defconst ediff-ignore-similar-regions t)                                                                                                                                                            
(defconst ediff-use-last-dir t)                                                                                                                                                                      
(defconst ediff-diff-options " -b ")                                                                                                                                                                 

(setq dired-listing-switches "-l")      ;better list display                                                                                                                                         
(setq ls-lisp-dirs-first t)             ;display dirs first in dired                                                                                                                                 

;; Specify where backup files are stored                                                                                                                                                             
(setq backup-directory-alist (quote ((".*" . "~/.backups"))))                                                                                                                                        

(setq custom-file "~/.emacs-custom.el") ;what to load if error                                                                                                                                       
(load custom-file 'noerror)                                                                                                                                                                          

;; Type brackets in pairs                                                                                                                                                                            
(setq skeleton-pair t)                                                                                                                                                                               
(global-set-key (kbd "[") 'skeleton-pair-insert-maybe)                                                                                                                                               
(global-set-key (kbd "{") 'skeleton-pair-insert-maybe)                                                                                                                                               
(global-set-key (kbd "\"") 'skeleton-pair-insert-maybe)

;;; Common Lisp                                                                                                                                                                                      
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                                                                                                                                                             

;; Specify modes for Lisp file extensions                                                                                                                                                            
(setq auto-mode-alist                                                                                                                                                                                
(append '(                                                                                                                                                                                     
("\\.lisp$" . lisp-mode)                                                                                                                                                             
("\\.lsp$" . lisp-mode)                                                                                                                                                              
("\\.cl$" . lisp-mode)                                                                                                                                                               
("\\.asd$" . lisp-mode)                                                                                                                                                              
("\\.system$" . lisp-mode)                                                                                                                                                           
)auto-mode-alist))                                                                                                                                                                   

;; SLIME and generic Common Lisp.                                                                                                                                                                    
(require 'slime)                                                                                                                                                                                     

(setq slime-edit-definition-fallback-function 'find-tag)                                                                                                                                             

(setq inferior-lisp-program "sbcl"                                                                                                                                                                   
lisp-indent-function 'common-lisp-indent-function                                                                                                                                               
slime-complete-symbol-function 'slime-fuzzy-complete-symbol                                                                                                                                     
common-lisp-hyperspec-root "file:/usr/share/doc/hyperspec/" ;; Debian                                                                                                                           
slime-startup-animation t)                                                                                                                                                                      

(add-hook 'lisp-mode-hook (lambda () (slime-mode t)))                                                                                                                                                
(add-hook 'slime-repl-mode-hook (lambda () (slime-mode t)))                                                                                                                                          
(add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode t)))                                                                                                                              

(defun customised-lisp-keyboard()                                                                                                                                                                    
(local-set-key [C-tab] 'slime-fuzzy-complete-symbol)                                                                                                                                               
(local-set-key [return] 'newline-and-indent))                                                                                                                                                      

(add-hook 'lisp-mode-hook 'customised-lisp-keyboard)                                                                                                                                                 

(global-set-key "\C-cs" 'slime-selector)                                                                                                                                                             

;; Search in lispdoc.org                                                                                                                                                                             
(defun lispdoc ()                                                                                                                                                                                    
"Searches lispdoc.com for SYMBOL, which is by default the symbol                                                                                                                                   
currently under the curser. Use M-x lispdoc"                                                                                                                                                         
(interactive)                                                                                                                                                                                      
(let* ((word-at-point (word-at-point))                                                                                                                                                             
(symbol-at-point (symbol-at-point))                                                                                                                                                         
(default (symbol-name symbol-at-point))                                                                                                                                                     
(inp (read-from-minibuffer                                                                                                                                                                  
(if (or word-at-point symbol-at-point)                                                                                                                                                
(concat "Symbol (default " default "): ")                                                                                                                                         
"Symbol (no default): "))))                                                                                                                                                      
(if (and (string= inp "") (not word-at-point) (not                                                                                                                                               
symbol-at-point))                                                                                                                              
(message "you didn't enter a symbol!")                                                                                                                                                       
(let ((search-type (read-from-minibuffer                                                                                                                                                       
"full-text (f) or basic (b) search (default b)? ")))                                                                                                                     
(browse-url (concat "http://lispdoc.com?q="                                                                                                                                                  
(if (string= inp "")                                                                                                                                                 
default                                                                                                                                                          
inp)                                                                                                                                                       
"&search="                                                                                                                                                       
(if (string-equal search-type "f")                                                                                                                           
"full+text+search"                                                                                                                                       
"basic+search")))))))
;; Fontify *SLIME Description* buffer                                                                                                                                                                
(defun slime-description-fontify ()                                                                                                                                                                  
"Fontify sections of SLIME Description."                                                                                                                                                           
(with-current-buffer "*SLIME Description*"                                                                                                                                                         
(highlight-regexp                                                                                                                                                                                
(concat "^Function:\\|"                                                                                                                                                                         
"^Macro-function:\\|"                                                                                                                                                                   
"^Its associated name.+?) is\\|"                                                                                                                                                        
"^The .+'s arguments are:\\|"                                                                                                                                                           
"^Function documentation:$\\|"                                                                                                                                                          
"^Its.+\\(is\\|are\\):\\|"                                                                                                                                                              
"^On.+it was compiled from:$")                                                                                                                                                          
'hi-green-b)))                                                                                                                                                                                  

(defadvice slime-show-description (after slime-description-fontify activate)                                                                                                                         
"Fontify sections of SLIME Description."                                                                                                                                                           
(slime-description-fontify))                                                                                                                                                                       

;; Use W3M                                                                                                                                                                                           
(require 'w3m)                                                                                                                                                                                       

(defun w3m-browse-url-other-window (url &optional newwin)                                                                                                                                            
(interactive                                                                                                                                                                                       
(browse-url-interactive-arg "w3m URL: "))                                                                                                                                                         
(let ((pop-up-frames nil))                                                                                                                                                                         
(switch-to-buffer-other-window                                                                                                                                                                   
(w3m-get-buffer-create "*w3m*"))                                                                                                                                                                
(w3m-browse-url url)))                                                                                                                                                                           

(setq browse-url-browser-function                                                                                                                                                                    
(list (cons "^ftp:/.*"  (lambda (url &optional nf)                                                                                                                                             
(call-interactively #'find-file-at-point url)))                                                                                                                      
(cons "."  #'w3m-browse-url-other-window)))                                                                                                                                          

;;; JavaScript                                                                                                                                                                                       
;;; http://web.comhem.se/~u34308910/emacs.html#javascript                                                                                                                                            
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                                                                                                                                                             

(autoload 'javascript-mode "javascript" nil t)                                                                                                                                                       
(add-to-list `auto-mode-alist `("\\.js\\'" . javascript-mode)) 

;;; Helper functions                                                                                                                                                                                 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 

Сега нещата стоят по друг начин, писането на Lisp е песен. Ето и командите, които най-често използвам:

LISP RELATED

; Parants
M-( Prints ()

; Compilation
C-c M-k slime-compile-file
C-c C-c slime-compile-defun

; Evaluation
C-M-x slime-eval-defun

; Documentation
C-c C-d a slime-apropos
C-c C-d h slime-hyperspec-lookup
C-c C-m slime-macroexpand-1

; Cross-reference
C-c C-w r slime-who-references

; Manage Slime
M-x slime start slime
C-c C-c slime compile defun
C-c C-k slime compile and load file
C-c M-g slime quit

C-c C-t slime clear repl
M-p slime prev command
M-n slime next command

M-r slime search prev commands
M-s slime search next commands

C-c C-z go to lisp buffer
C-c C-q close all parens

Ето един много добър линк за Emacs командите: Beyond Emacs Tutorial

Oстана да се добави малко творчество и нещата добиват завършен вид. Горе долу подхода ми е следния:

   1. Всичко(functions, classes, special variables, and constants) го слагам в defun, за да мога лесно да го проверя дали има грешки с С-с С-с. Ако нещо много ме усъмни(да проверя нещо как работи) се прехвърлям на REPL с C-c C-z и го изпълнявам.


   2. Програмата трябва да е lоаdable, сиреч да не се прави нищо допълнително, за да може да се стартира самостоятелно. Ако програмата да кажем, че се казва proba.lisp не ползва допълнителни библиотеки, тогава няма нищо за правене. По-сложнен е другия случай, да иска. Да кажем ползва cl-ppcre. Тогава в кода има:

(defpackage #:proba
(:use #:cl #:cl-ppcre))

Това само по себе си не е достатъчно. Ако направим:

(load (compile-file "proba"))

Получаваме следната грешка: The name "CL-PPCRE" does not designate any package. Ха сега де.
По някакъв начин трябва да съм сигурен, че cl-ppcre ще се зареди и компилира преди моя файл proba.lisp. Най-лесния вариант е да изплзвам ASDF. Създавам един файл proba.asd и в него слагам:

(asdf:defsystem #:proba
:depends-on (#:cl-ppcre)
:components ((:file "proba")))

Ако пък работя в REPL-a ще използвам: ,load-system или (asdf:oos 'asdf:load-op 'proba)


   3. Ами ако проета от един файл нарасне и стане проект? Тогава ще се наложи да разделяме на малки файлове и да ги "вържем" по някакъв начин. Да речем proba.lisp нарасне много и аз реша да го рефакторирам и изкарам някои операции в друг файл - operations.lisp. За целта ще се наложи да работя с пакети. Създавам файла package.lisp и в началото на proba.lisp и operations.lisp указвам, на кой пакет пренадлежат.

(in-package #:proba)

Послендия файл ще изглежда малко променен:

(asdf:defsystem #:proba
:depends-on (#:cl-ppcre)
:components ((:file "package")
(:file "operations"
:depends-on ("package"))
(:file "proba"
:depends-on ("package"
"operations"))))

   4. Приготвям се за финиширане като се попитам: А какви са нещата от проекта, които могат да се използеват дирекно(кои са интерфейсите)? Определям ги и променям пакетната дефиниция в package.cl:

(defpackage #:proba
(:use #:cl #:cl-ppcre)
(:export #:blah
#:blah2
#:useful-thing3
#:*logfile-directory*))

   5. И накрая малко хитрости. Винаги стартирам проета си от неговата директория. Ако съм направил нещо наистина полезно правя нещата още по-глобални като линквам .asd в ~/.sbcl/systems/.

cd ~/.sbcl/system
ln -s ../../Lisp/proba/proba.asd .

Така много лесно мога да си ползвам проета отвсякъде като пиша просто:(require 'proba). Или ако от друг проект ми притрябват моите "полезни" неща от proba. Просто:

(asdf:defsystem #:useful_thing3
:depends-on (#:proba #:drakma)
:components (...))

В общи линии така върви моя Лисп път.

The Zen of LISP clusure

Definitions:
A function plus its enviroment is called a closure.

A closure typically comes about when one function is declared entirly within the body of another, and inner function refer to local variables of the outer function.

Example:

(defparameter *fn* 
 (let ((count 0))
  #'(lambda () (setf count (1+ count))))) ; function closure.

count is lambda enviroment( or lambda use count ).

Possible usage: Closures can be used for modularity so you don't have to encapsulate data in classes to prevent it from becoming global.

Тhe names introduced by a LET form turns out not to be a name binding to some immutable values. The names refer to local variables! Such variables(a.k.a lexical variables) follow typical lexical scoping rules, so that LISP always looks up the innermost variable definition when a variable name is to be evaluated.

Example:

(defun bar () 
  (foo) 
  (let ((*x* 20)) (foo)) 
  (foo)) 

CL-USER: (bar) 
X: 10 
X: 20 
X: 10 
NIL 

Definition:
A lexical variable is a variable that can only be referenced at the textual location of the code that creates it.

Everything starts from LET (a.k.a binding form). Here is the LET definition:

(let (variable*) 
  body-form*)

where each variable is a variable initialization form. When the LET form is evaluated, all the initial value forms are first evaluated. Then new bindings are created and initialized to the appropriate initial values before the body forms are executed. Within the body of the LET, the variable names refer to the newly created bindings. After the LET, the names refer to whatever, if anything, they referred to before(out of local scope) the LET. What happend when we use this variable in inner defined function?

What is more interesting is that, due to the ability to return functions as values, the local variable has a life span longer than the expression defining it. Consider the following example:

CL-USER: (setf inc (let ((counter 0)) 
                      #'(lambda () 
                          (incf counter))))
inc
CL-USER: (funcall inc)
1
CL-USER: (funcall inc)
2
CL-USER: (funcall inc)
3


                                      +---------------------+
                                      |                     |
                    +-------- lambda function --------+     |
                    |    func. enviroment             |     |use
               ref. |               ===========       |     |
INC --------------> |               | counter |<------|---- +
                    |               ===========       |
                    +---------------------------------+

counter has nice "secret" live inside lambda function.
We assign a value to the global variable inc. That value is obtained by first defining local variable counter using LET, and then within the lexical scope of the local variable, a lambda expression is evaluated, thereby creating an annonymous function, which is returned as a value to be assigned to inc. The most interesting part is in the body of that lambda expression - it increments the value of the local variable counter! When the lambda expression is returned, the local variable persists, and is accessible only through the annonymous function.

The thing to remember from this example is that, in other kinds of languages like Java and C/C++ the lexical scope of a local variable somehow coincide with its life span. After executation passes beyond the boundary of a lexical scope, all the local variables defined within it cease to exist. This is not true in languages supporting that return functions as values. Lexical scoping is enforced strictly, and therefore the only place from which you can alter the value of counter is within the lexical scope of the variable - the lambda expression. As a result, the counter state is effectively encapsulated. The only way to modify it is by going through the annonymous function stored in inc. The technical term to refer to this thing that is stored in inc, this thing that at the same time captures both the definition of a function and the variables referenced within the function body is called a function closure.

NOTE: If you keep in mind that "#'" means roughly "allocate (in the heap)
a closure for the following LAMBDA expression".

What if we want to define multiple interface functions for the encapsulated counter? Simple, just return all of them:

CL-USER: (setf list-of-funcs (let ((counter 0))
                                (list #'(lambda ()
                                          (incf counter))
                                      #'(lambda ()
                                          (setf counter 0)))))
CL-USER: (setf inc (first list-of-funcs))
CL-USER: (setf reset (second list-of-funcs))
CL-USER: (funcall inc)
1
CL-USER: (funcall inc)
2
CL-USER: (funcall inc)
3
CL-USER: (funcall reset)
0
CL-USER: (funcall inc)
1

NIRVANA!