#+TITLE:     ob-scheme tests
#+AUTHOR:    Michael Gauland
#+EMAIL:     mikelygee@no8wireless.co.nz
#+DATE:      2012-12-10 Mon
#+DESCRIPTION:
#+KEYWORDS:
#+LANGUAGE:  en
#+OPTIONS:   H:3 num:nil toc:nil \n:nil @:t ::t |:t ^:{} -:t f:t *:t <:t
#+OPTIONS:   TeX:t LaTeX:t skip:nil d:nil todo:t pri:nil tags:not-in-toc
#+INFOJS_OPT: view:nil toc:nil ltoc:t mouse:underline buttons:0 path:http://orgmode.org/org-info.js
#+EXPORT_SELECT_TAGS: export
#+EXPORT_EXCLUDE_TAGS: noexport
#+LINK_UP:   
#+LINK_HOME: 
#+XSLT:
#+LATEX_HEADER: \lstset{keywordstyle=\color{blue}\bfseries}
#+LATEX_HEADER: \lstset{frame=shadowbox}
#+LATEX_HEADER: \lstset{basicstyle=\ttfamily}
#+LATEX_HEADER: \definecolor{mygray}{gray}{0.8}
#+LATEX_HEADER: \lstset{rulesepcolor=\color{mygray}}
#+LATEX_HEADER: \lstdefinelanguage{scheme}{rulesepcolor=\color{mygray},frameround=ffff,backgroundcolor=\color{white}}
#+LATEX_HEADER: \lstdefinelanguage{Lisp}{rulesepcolor=\color{mygray},frameround=ffff,backgroundcolor=\color{white}}
#+LATEX_HEADER: \lstdefinelanguage{fundamental}{rulesepcolor=\color{blue},frameround=tttt,backgroundcolor=\color{mygray}}
#+PROPERTY: exports both
#+PROPERTY: wrap SRC fundamental

* Implementation Selection
  These tests exercise the values that determine which scheme implementation is run:
  + The =:scheme= property
  + =geiser-default-implementation=
  + The first value of =geiser-active-implementations=
  These variables currently have the values shown below. They will be changed
  during these tests, and restored afterwards.
  #+BEGIN_SRC emacs-lisp :wrap :exports results
    (list (list "Variable" "Value")
     (list "org-babel-default-header-args:scheme"
           org-babel-default-header-args:scheme)
     (list "geiser-default-implementation" geiser-default-implementation)
     (list "geiser-active-implementations" geiser-active-implementations))
  #+END_SRC

  #+RESULTS:
  | Variable                             | Value                |
  | org-babel-default-header-args:scheme | ((:scheme . racket)) |
  | geiser-default-implementation        | nil                  |
  | geiser-active-implementations        | (guile racket)       |

  # Record the version numbers of the scheme interpreters for reference:
  #+BEGIN_SRC emacs-lisp :wrap :exports results :results output
    (setq guile-version nil)
    (setq racket-version nil)
    (let ((get-version
           (lambda (binary)
             (with-temp-buffer
               (shell-command
                (concat "\"" binary "\""
                        " --version")
                (current-buffer))
               (goto-char (point-min))
               (search-forward-regexp "[0-9]\\(\.[0-9]+\\)+")
               (buffer-substring (match-beginning 0) (match-end 0))))))
      (setq guile-version (apply get-version (list geiser-guile-binary)))
      (setq racket-version (apply get-version (list geiser-racket-binary))))
  #+END_SRC

#+MACRO: guile-version src_emacs-lisp[:exports results :wrap]{guile-version}
#+MACRO: racket-version src_emacs-lisp[:exports results :wrap]{racket-version}
  These tests are being run with guile version {{{guile-version}}}, and racket version {{{racket-version}}}.

  # Create source block to restore the settings
  #+NAME: geiser-restore
  #+BEGIN_SRC emacs-lisp :wrap "SRC emacs-lisp :exports both" :exports results
    (let ((generate-script
           (lambda (v)
             (if v (concat
                    "'"
                    (with-output-to-string (princ v)))
               "nil"))))
      (concat "(progn\n "
              "(setq org-babel-default-header-args:scheme \n    "
              (funcall generate-script org-babel-default-header-args:scheme)
              ")\n"
              "(setq geiser-default-implementation \n    "
              (funcall generate-script geiser-default-implementation)
              ")\n"
              "(setq geiser-active-implementations \n    "
              (funcall generate-script geiser-active-implementations)
              "))"))
  #+END_SRC

    + Set values to (), nil, (guile, racket)
    #+BEGIN_SRC emacs-lisp :wrap :exports both :results output
    (setq org-babel-default-header-args:scheme (list))
    (setq geiser-default-implementation nil)
    (setq geiser-active-implementations '(guile racket))
    #+END_SRC

  + Run; verify guile
    This block should return {{{guile-version}}}:
    #+BEGIN_SRC scheme
    (version)
    #+END_SRC

  + Reverse geiser-active-implementations
    #+BEGIN_SRC emacs-lisp :exports both :results value
      (setq geiser-active-implementations
            (reverse geiser-active-implementations))
    #+END_SRC
  + Run; verify racket

    This block should return {{{racket-version}}}:
    #+BEGIN_SRC scheme
    (version)
    #+END_SRC
  + Set geiser-default-implementation to guile
    #+BEGIN_SRC emacs-lisp :exports both
    (setq geiser-default-implementation 'guile)
    #+END_SRC
  + Run; verify guile
    This block should return {{{guile-version}}}:
    #+BEGIN_SRC scheme
    (version)
    #+END_SRC
    
  + Set =org-babel-default-header-args:scheme= to =(('scheme . 'racket))=:
    #+BEGIN_SRC emacs-lisp :exports both
      (setq org-babel-default-header-args:scheme
            '((:scheme .  "racket")))
    #+END_SRC

  + Run; verify 
    This block should return {{{racket-version}}}:
    #+BEGIN_SRC scheme
    (version)
    #+END_SRC


  + Run a block with =:scheme guile=; expect guile.
    This block should return {{{guile-version}}}:
    #+BEGIN_SRC scheme :scheme guile
    (version)
    #+END_SRC

  + Restore variables
    #+RESULTS: geiser-restore
    #+BEGIN_SRC emacs-lisp :exports both
    (progn
     (setq org-babel-default-header-args:scheme nil)
    (setq geiser-default-implementation nil)
    (setq geiser-active-implementations '))
    #+END_SRC

    #+BEGIN_SRC emacs-lisp :wrap :exports results
      (list (list "Variable" "Value")
            (list "org-babel-default-header-args:scheme"
                  org-babel-default-header-args:scheme)
            (list "geiser-default-implementation"
                  geiser-default-implementation)
            (list "geiser-active-implementations"
                  geiser-active-implementations))
    #+END_SRC

* sessions
  + Without a session, re-define 'version':
    #+BEGIN_SRC scheme :exports code
    (define version (lambda () "This test fails."))
    #+END_SRC

  + In a new block, without a session, (version) should return a number:
    #+BEGIN_SRC scheme
    (version)
    #+END_SRC

  + With an unamed session, re-define 'version':
    #+BEGIN_SRC scheme :session :exports code
      (define version
        (lambda ()
          "This is the unnamed session."))
    #+END_SRC

  + In a new block, with an unnamed session, (version) should return =This is
    the unnamed session=:
    #+BEGIN_SRC scheme :session
    (version)
    #+END_SRC

    Make sure the change doesn't affect a non-session block:
    #+BEGIN_SRC scheme
    (version)
    #+END_SRC

  + Start a named session, and re-define 'version':
    #+BEGIN_SRC scheme :session named-session-1 :exports code
      (define version
        (lambda ()
          "This is named-session-1."))
    #+END_SRC

  + Make sure the change doesn't affect a non-session block:
    #+BEGIN_SRC scheme
    (version)
    #+END_SRC

  + ...or an unnamed session block:
    #+BEGIN_SRC scheme :session
    (version)
    #+END_SRC

  + ...but is retained for a new block with the same session name:
    #+BEGIN_SRC scheme :session named-session-1
    (version)
    #+END_SRC


* output vs. value
  :PROPERTIES:
  :session:  output-value-session
  :END:
  #+BEGIN_SRC scheme :results output 
  (display "This test pases")
  "This test FAILS"
  #+END_SRC

  #+BEGIN_SRC scheme :results value
  (display "This test FAILS")
  "This test passes"
  #+END_SRC

  #+BEGIN_SRC scheme :results output
  (display "This is the first line.")
  (newline)
  (display "This is the second line.\n")
  (display "This is the third line.")
  "This test FAILS."
  #+END_SRC

  #+BEGIN_SRC scheme :results value
    (display "This test FAILS.")
    (string-join
     (list "This is the first line."
           "This is the second line."
           "This is the third line.")
     "\n")
  #+END_SRC

  #+BEGIN_SRC scheme :results output
  (display '(1 2 3 4 5 6))
  "This test FAILS"
  #+END_SRC

  #+BEGIN_SRC scheme :results value :wrap
  (display "This test FAILS")
  '(1 2 3 4 5 6)
  #+END_SRC

  #+BEGIN_SRC scheme :results output
  (display '((1 2 3)(4 5 6)(7 8 9)))
  "This test FAILS"
  #+END_SRC

  #+BEGIN_SRC scheme :results value
  (display "This test FAILS")
  '((1 2 3)(4 5 6)(7 8 9))
  #+END_SRC

* :var
  This block should return =64=:
  #+BEGIN_SRC scheme :results value :var x=8
  (* x x)
  #+END_SRC

  This block should return the string ="A B C D E"=:
  #+BEGIN_SRC scheme :results value :var y="E D C B A"
  (string-reverse y)
  #+END_SRC


  This block should return the list =(1 4 9 16 25)= (which org will display as a table).
  #+BEGIN_SRC scheme :results value :var z='(1 2 3 4 5) :wrap nil
  (map (lambda (x) (* x x)) z)
  #+END_SRC

* Tables
  :PROPERTIES:
  :wrap:     nil
  :session:  nil
  :END:
  Pass a table to scheme:
  #+NAME: data-table
  |       | A | B | C | D |  E |
  | Row 1 | 1 | 2 | 3 | 4 |  5 |
  | Row 2 | 6 | 7 | 8 | 9 | 10 |

  This block should show the table above:
  #+BEGIN_SRC scheme :scheme racket :results value :session :var x=data-table
  x
  #+END_SRC

  This block rerses the table left to right:
  #+BEGIN_SRC scheme :scheme racket :results value :session :var x=data-table
  (map reverse x)
  #+END_SRC

  This block will be passed to scheme with the column headers removed; the data
  and row labels will be reversed, but the column labels will not.
  #+BEGIN_SRC scheme :scheme guile :results value :session :var x=data-table :colnames t
  (map reverse x)
  #+END_SRC

  This block will be passed to scheme with the row headers removed; the data
  and column labels will be reversed, but the row labels will not.
  #+BEGIN_SRC scheme :scheme guile :results value :session :var x=data-table :rownames t
  (map reverse x)
  #+END_SRC

  This block will be passed to scheme with bothe the row and column headers
  removed; the data will be reversed, but the row and columns labels will not.
  #+BEGIN_SRC scheme :scheme guile :results value :session :var x=data-table :colnames nil :rownames t
  (map reverse x)
  #+END_SRC

  This block will adds a row of data; note that the column and row headers are lost:
  #+BEGIN_SRC scheme :scheme guile :results value :session :var t=data-table :colnames t :rownames t
    (let* ((row-1 (car t))
           (row-2 (cadr t))
           (total (map + row-1 row-2)))
    (append t (list total)))
  #+END_SRC

  This block adds a row of data, but handles the column and row headers in scheme:
  #+BEGIN_SRC scheme :scheme guile :results value :session :var t=data-table
    (let* ((col-labels (car t))
           (row-1 (cadr t))
           (row-2 (caddr t))
           (total (append
                   '(Total)
                   (map + (cdr row-1)  (cdr row-2)))))
        (append t (list total)))
  #+END_SRC