Function as Functor in Haskell programming language

I was really confused with the Function as Functor and tried to understand what (->) r really means.

Already many explanations about this but still I could find out what the "fixing" of input type "r" in "(->) r" really means.

     It is really similar to the approach to (Either a) b, where the first type "a" is fixed.
     And we can see that :k Either is same as :k (->), both of them are "kind" of *-> * -> * .
     So we have to fix them to have the signature like *-> *, e.g., (->) Int or Either Int has.

     But what does the fix of type mean?
     To me, if we say fix the input parameter type of the function, e.g., "(-) r", it means we don't need to bother to handle mapping over "r",
     but only focus on mapping over of the mapping over of type of result, "a" in "(->) r a", which in turn means we have to map it to "(->) r b".
     You can see "r" is the same , (meaning fixed), above, but the result type changes from "a" to "b".

I will be really happy if I can help somebody to have a deeper understanding, though I am not using academic terms in Haskell.

a haskell implementation of Sieve of Eratosthenes

As a novice of Haskell, tried to implemented a piece of code of Sieve of Eratosthenes.
Quite redundant now, maybe.

prim' :: (Integral a) => [a] -> [a]
prim' []= []
prim' (x:xs) = x : (prim' $ foldl (\acc z -> if (z `mod` x) == 0 then acc else acc ++ [z]) [] xs)

Here is the testing result of it.

> prim' [2..100]
[2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97]

an elisp function for org mode of emacs

Just a memo of initial setting for org-mode of emacs;
M-x show-org-buffer to switch to the memo specified by user.

(global-set-key "\C-cl" 'org-store-link)
(global-set-key "\C-ca" 'org-agenda)
(global-set-key "\C-cc" 'org-capture)
(global-set-key "\C-cb" 'org-switchb)
(setq org-capture-templates
      '(("n" "Note" entry (file+headline "c:/Users/xxx/Documents/memo/notes.org" "Notes")
         "* %?\nEntered on %U\n %i\n %a")
    ("j" "Journal" entry (file+datetree "c:/Users/xxx/Documents/memo/journal.org")
     "* %?\nEntered on %U\n %i\n %a")
        ))

(defun show-org-buffer(n-type)
  "Show an org-file FILE on the current buffer."
  (interactive "sNotes(n,j):")
  (let ((dir "c:/Users/dongsche1/Documents/memo/"))
    (let ((file (concat dir
            (progn
              (if (string= n-type "n")
                  "notes.org"
                "journal.org")))))
      (if (get-buffer file)
      (let ((buffer (get-buffer file)))                             
            (switch-to-buffer buffer)                                   
            (message "%s" file))
    (find-file file)))))

json parse for xyzzy (a lisp compatible editor)

Json is widely used and could not find a decent json parse for xyzzy.
So I decided to create on by myself.
Here is the source code though not very detailed version, I used for my everyday work and happy with it.

Created almost one year ago, almost forgot the details...

(provide "formatter")
(in-package "editor")

(export 'fmtjson)

(defvar **lv** 0)

(defmacro setlvl (bdy)
  `(progn
    (setq **lv** (1+ **lv**))
     ,bdy
     (setq **lv** (1- **lv**))))


;;(defmacro fnlvl (fn param bdy)
;;  `(defun fn (param)
;;    ))
(defmacro spc(n)
  `(let ((str ""))
    (dotimes (ct (* ,n 2) str)
      (setq str (format nil "~A " str)))))



(defmacro fmtspc (iot fmt parm)
  `(format ,iot (concatenate 'string "~A" ,fmt) (spc **lv**) ,@parm))

(defun getobj (strm)
  (let ((x nil)
    (y nil))
    (let ((ret
       (if (eq (read-char strm nil) #\{)
           (progn
         (setq **lv** (1+ **lv**))
         ;;(while (eq (setq x (read-char strm nil)) #\Space))
      (setq x (read-char strm nil))
         (if (eq x #\})
             (format nil "{~%~A}~%~A" (spc (1- **lv**)) (spc **lv**))
           (progn
          (unread-char x strm)
             (setq y (getmembr strm))
             ;(while (eq (setq x (read-char strm nil)) #\Space))
             ;; have to make sure inner getmembr does not consume the #\}.
             ;;(if (eq x nil)
        ;;  (progn
             ;;  (setq y (substring y 0 4))
             ;; (setq x #\})))
             ;;(unread-char x strm)
             (if (eq (read-char strm nil) #\})
             (format nil "{~%~A~A~A}" (spc **lv**) y (spc (1- **lv**)) ))))))))
      (setq **lv** (1- **lv**))
      ret)))
   
(defun getmembr (strm)
  (let ((x (getpair strm))
    (y nil))
    (if (eq (setq y (read-char strm nil)) #\,)
    (format nil "~A,~%~A~A" x (spc **lv**) (getmembr strm))
      (progn
    (unread-char y strm)
    (format nil "~A~%" x (spc **lv**))))))

(defun getpair (strm)
  (let ((x (getstr strm)))
    (read-char strm nil)
    (format nil "~A : ~A" x (getval strm))))

(defun getstr (strm)
  (read-char strm nil)
  (let ((str "")
    (x nil))
    ;(x (read-char strm nil)))
    (while (not (eq (setq x (read-char strm nil)) #\"))
      ;(if (eq x #\\)
;      (progn
;        (setq str (format "~A~C" str x))
;        (format "~A~C" str (read-char strm nil)))
      (setq str (format nil "~A~C" str x)))
;    (progn
 ;     (unread-char x strm)
    (format nil "\"~A\"" str)))

(defun getval(strm)
  ;;;(getstr strm))
  (let ((x (read-char strm nil)))
    (cond ((eq x #\")
       (unread-char x strm)
       (getstr strm))
      ((eq x #\{)
       (unread-char x strm)
       (getobj strm))
      ((eq x #\[)
       (unread-char x strm)
       (getarr strm))
      ((or (eq x #\-)
           (and (char>= x #\0)
            (char<= x #\9)))
       (unread-char x strm)
       (getnum strm))
      ((eq x #\t)
       (unread-char x strm)
       (getT strm))
      ((eq x #\f)
       (unread-char x strm)
       (getF strm))
      ((eq x #\n)
       (unread-char x strm)
       (getN strm))
      (t (unread-char x strm)))))


(defun getarr (strm)
  (setq **lv** (1+ **lv**))
  (read-char strm nil)
  (let ((x (read-char strm nil)))
    (let ((ret
    (if (eq x #\])
    (format nil "[~%~A]~%~A" (spc (1- **lv**)) (spc **lv**))
      (progn
    (unread-char x strm)
    (let ((y (getelm strm)))
      (if (eq (read-char strm nil) #\])
          (format nil "[~%~A~A~A]" (spc **lv**) y (spc (1- **lv**)))
        y))))))
      (setq **lv** (1- **lv**))
      ret)))

(defun getelm (strm)
  (let ((x (getval strm))
    (y (read-char strm nil)))
    (if (eq y #\,)
    (format nil "~A ,~%~A~A" x (spc **lv**) (getelm strm))
      (progn
    (unread-char y strm)
    (format nil "~A~%" x (spc **lv**))))))

(defun getnum (strm)
  (let ((x (getint strm))
    (y (read-char strm nil)))
    (cond ((eq y #\.)
       (unread-char y strm)
       (let ((z (getfrac strm))
         (i (read-char strm nil)))
         (if (or (eq i #\e)
             (eq i #\E))
         (progn
           (unread-char i strm)
           (format nil "~A~A~A" x z (getexp strm)))
           (progn
         (unread-char i strm)
         (format nil "~A~A" x z)))))
      ((or (eq y #\e)
           (eq y #\E))
       (unread-char y strm)
       (format nil "~A~A" x (getexp strm)))
      (t (unread-char y strm)
         (format nil "~A" x)))))

(defun getfrac (strm)
  (let ((x (read-char strm nil)))
    (format nil "~C~A" x (getdigt strm))))

(defun getexp (strm)
  (let ((e (read-char strm nil))
    (s (read-char strm nil)))
    (if (or (eq s #\+)
        (eq s #\-))
    (format nil "~C~C~A" e s (getdigt strm))
      (progn
    (unread-char s strm)
    (format nil "~C~A" e (getdigt strm))))))

(defun getint (strm)
  (let ((dig (read-char strm nil)))
    (cond ((eq dig #\0)
       (format nil "~C" dig))
      ((eq dig #\-)
       (let ((x (read-char strm nil)))
         (if (eq x #\0)
         (format nil "~C~C" dig x)
           (format nil "~C~C~A" dig x (getdigt strm)))))
      ((and (char>= dig #\1)
        (char<= dig #\9))
       ;(unread-char dig strm)
       (format nil "~C~A" dig (getdigt strm)))
      (t (unread-char dig strm)))))
         
(defun getdigt (strm)
  (let ((dgt (read-char strm nil)))
    (if (not (and (char>= dgt #\0)
          (char<= dgt #\9)))
    (progn
      (unread-char dgt strm)
      "")
      (format nil "~A~A" (string dgt) (getdigt strm)))))

(defun getT (strm)
  (let ((str ""))
    (while (alpha-char-p (setq x (read-char strm nil)))
      (setq str (format nil "~A~C" str x)))
    (unread-char x strm)
    str))

(defun getF (strm)
  (let ((str ""))
    (while (alpha-char-p (setq x (read-char strm nil)))
      (setq str (format nil "~A~C" str x)))
    (unread-char x strm)
    str))

(defun getN (strm)
  (let ((str ""))
    (while (alpha-char-p (setq x (read-char strm nil)))
      (setq str (format nil "~A~C" str x)))
    (unread-char x strm)
    str))

(defun fmtjson ()
  (interactive)
  (setq **lv** 0)
  (case (get-selection-type)
    ((1 2 3)
     (kill-selection)
     ;(let ((str (remove #\RET (remove #\TAB (remove #\LFD (cdr (car *selection-ring*)))))))
     (let ((flg 0) (str ""))
       (map nil
            #'(lambda (c)
                (case c
                  (#\"
                    (if (eq flg 1)
                        (setq flg 0)
                      (setq flg 1))
                    (setq str (format nil "~A~C" str c)))
                  ((#\SPC #\RET #\LFD #\TAB)
                   (if (eq flg 1)
                       (setq str (format nil "~A~C" str c))))
                  (t (setq str (format nil "~A~C" str c)))))
            (cdr (car *selection-ring*)))
       (case (char str 0)
         (#\{
           (insert (format nil "~A" (with-input-from-string (strm str) (getobj strm)))))
         (#\[
           (insert (format nil "~A" (with-input-from-string (strm str) (getarr strm))))))))))

a compiler with open-code primitives - solution of exercise 5.38 of SICP

Long time not to post on the blog.

Here is part of the code of the solution of Exercise 5.38 of SICP
You can find complete code for compiler part and syntax part.
--------------------------------------------------------------------
(define (compile-primitive-plus exp target linkage)
  (define (iter exp target)
    (let ((args (operands exp)))
      (if (null? (cddr args))
      (append-instruction-sequences
       (spread-arguments args)
       (make-instruction-sequence
        '(arg1 arg2)
        '(val)
        `((assign val (op +) (reg arg1) (reg arg2)))))
      (append-instruction-sequences
       (compile (car args) 'arg1 'next)
       (preserving
        '(arg1 env)
        (iter (cons '+ (cdr args)) 'val)
        (make-instruction-sequence
         '(arg1)
         '(val)
         `((assign val (op +) (reg arg1) (reg val)))))))))
  (end-with-linkage
   linkage
   (append-instruction-sequences
    (iter exp target)
    (make-instruction-sequence
     '(val) '(,target)
     `((assign ,target (reg val)))))))

(define (compile-primitive-multiply exp target linkage)
  (define (iter exp target)
    (let ((args (operands exp)))
      (if (null? (cddr args))
      (append-instruction-sequences
       (spread-arguments args)
       (make-instruction-sequence
        '(arg1 arg2)
        '(val)
        `((assign val (op *) (reg arg1) (reg arg2)))))
      (append-instruction-sequences
       (compile (car args) 'arg1 'next)
       (preserving
        '(arg1 env)
        (iter (cons '* (cdr args)) 'val)
        (make-instruction-sequence
         '(arg1)
         '(val)
         `((assign val (op *) (reg arg1) (reg val)))))))))
  (end-with-linkage
   linkage
   (append-instruction-sequences
    (iter exp target)
    (make-instruction-sequence
     '(val) '(,target)
     `((assign ,target (reg val)))))))

(define (spread-arguments args)
  (let ((op1 (compile (car args) 'arg1 'next))
    (op2 (compile (cadr args) 'arg2 'next)))
    (append-instruction-sequences
     op1
     (preserving '(arg1)
         op2
         (make-instruction-sequence '(arg1) '() '())))))

a lazy explicit evaluator - solution of SICP exercise 5.25

Modified the explicit evaluator to a lazy one. And here are the main blocks I added.

actual-value
    (save continue)
    (save env)
    (save exp)
    (assign continue (label force-it))
    (goto (label eval-dispatch))
force-it
    (test (op thunk?) (reg val))
    (branch (label thunk-extract))
    (restore exp)
    (restore env)
    (restore continue)
    (goto (reg continue))
thunk-extract
    (assign env (op thunk-env) (reg val))
    (assign exp (op thunk-exp) (reg val))
    (goto (label actual-value))

Here is the whole source file

Playing with Fibonacci - solution of SICP exercise 5.29

Here is the exercise and my answer.

Exercise 5.29.  Monitor the stack operations in the tree-recursive Fibonacci computation:

(define (fib n)
  (if (< n 2)
      n
      (+ (fib (- n 1)) (fib (- n 2)))))

b. Give a formula for the total number of pushes used to compute Fib(n) for n > 2. You should find that the number of pushes (which correlates well with the time used) grows exponentially with n. Hint: Let S(n) be the number of pushes used in computing Fib(n). You should be able to argue that there is a formula that expresses S(n) in terms of S(n - 1), S(n - 2), and some fixed ``overhead'' constant k that is independent of n. Give the formula, and say what k is. Then show that S(n) can be expressed as a Fib(n + 1) + b and give the values of a and b.

My answer:

From Fibonacci function definition above, we can make the conclusion that
S(n) = S(n-1) + S(n-2) + k.
This looks already like the orignal Fibnacci sequence but let's have a look at S(0) and S(1).

S(0) contains only the overhead pushes, let's say this is [a], but not the k above.
S(1) is same.
For S(n) and n>2, k includes not only [a] but also pushes before computation of [+] of S(n-1) and S(n-2).

So S(n) should look like below:

a, a, 2a + k, 3a + 2k, 5a + 4k, ... ...
And the original Fibonacci is:
0, 1, 1, 2, 3, 5, ... ...

Then S(n) must has the format below.

aFib(n+1) + b.

And if given 2 total pushes, etc., S(1) and S(2), we can calculate the value of [a] and [k] as below.
a=16 and k=40.

Experiment: