Commit ea7b87b4 authored by Teodor Gelu Chiciudean's avatar Teodor Gelu Chiciudean
Browse files

Merge remote-tracking branch 'upstream/master'

Conflicts:
	evw.el
parents f2b0d261 f8a7a26d
......@@ -128,7 +128,21 @@
;; smlib shared library
;;
(ensure-directories-exist (merge-pathnames "SMLib8.18/" (the target-parent)))
(let ((smlib-name (if (find-package :smlib) (funcall (read-from-string "glisp:smlib-name"))
(error "smlib-name not known (smlib module probably not loaded)."))))
(glisp:copy-file (merge-pathnames (format nil "../../common/SMLib8.18/~a" smlib-name)
glisp:*genworks-source-home*)
(merge-pathnames (format nil "SMLib8.18/~a" smlib-name)
(the target-parent))))
;;
#+nil
(ensure-directories-exist (merge-pathnames "SMLib8.40/" (the target-parent)))
#+nil
(let ((smlib-name (if (find-package :smlib) (funcall (read-from-string "glisp:smlib-name"))
(error "smlib-name not known (smlib module probably not loaded)."))))
(glisp:copy-file (merge-pathnames (format nil "../../common/SMLib8.40/libs/~a/~a"
......
Clean startup on Ubuntu Linux (replace apt-get with the package manager
on your local Linux):
======================
$ == Linux shell prompt
* == Common Lisp shell prompt
M- or C- == Meta or Control command inside emacs
# == comment or manual action
$ cd
$ sudo apt-get install git
$ git clone git://gitub.com/genworks/Genworks-GDL.git
$ sudo apt-get install emacs
$ sudo apt-get install sbcl
$ sudo apt-get install curl
$ mkdir ~/cl
$ cd ~/cl
$ curl -O http://beta.quicklisp.org/quicklisp.lisp
$ cd ..
$ sbcl --load cl/quicklisp.lisp
* (quicklisp-quickstart:install)
* (ql:quickload :quicklisp-slime-helper)
# [Edit your .emacs or other emacs startup file as indicated]
* (quit)
$ emacs
M-x slime
* (load "~/quicklisp/setup")
* (load "~/Genworks-GDL/ql-register-local-project")
* (ql:quickload :gdl-all)
# [In web browser: visit: http://localhost:9000/tasty]
# [In field for package::class, enter robot:assembly]
# [click pencil icon next to Robot (shows up on mouseover]
......@@ -18,11 +18,12 @@
((:div :class "about_top")
((:div :class "about_bottom")
((:a :href "http://planet.lisp.org") ((:img :src "http://xach.com/img/jmc.jpg" :alt "John C McCarthy")))))
;;((:a :href (the home url)) ((:img :src "/site-static/images/icons/robot.gif" :alt "")))
;;((:a :href "http://planet.lisp.org") ((:img :src "http://xach.com/img/jmc.jpg" :alt "John C McCarthy")))
((:a :href (the home url)) ((:img :src "/site-static/images/icons/robot.gif" :alt "")))
))
((:div :class "about_top_left")
((:div :class "about_bottom_left")
......
#!/bin/bash
cd `dirname "$0"`
export os_platform=`uname`
export cl_platform=""
if [ "$1" == "sbcl" ]; then
cl_platform='SBCL'
fi
if [ "$os_platform" == "Linux" ]; then
if [ "$cl_platform" == "" ]; then
cl_platform='Allegro'
fi
emacs --no-splash --no-init-file -l devo.el
elif [ "$os_platform" == "Darwin" ]; then
if [ "$cl_platform" == "" ]; then
cl_platform='LispWorks'
fi
/Applications/Emacs.app/Contents/MacOS/Emacs --no-splash --no-init-file -l devo.el
fi
cd %~dp0
%windir%\system32\cmd.exe "/C start ..\..\common\gpl\gnu-emacs-23.3\bin\runemacs.exe --no-splash --no-init-file -l devo.el"
(require 'cl)
(load (expand-file-name "../../common/quicklisp/slime-helper.el"))
;;
;; FLAG -- learn how to add command line args to inferior-lisp-program
;; to load load.lisp for Genworks GDL automatically.
;;
(setq slime-lisp-implementations
(cond ((and (string= (getenv "cl_platform") "LispWorks")
(string= (getenv "os_platform") "Darwin"))
'((lw60-macosx-x86 ("../../common/lw60-macosx-x86/lw-console"))
(sbcl-1.0.52-x86-64-darwin ("sbcl"))))
((and (string= (getenv "cl_platform") "SBCL")
(string= (getenv "os_platform") "Darwin"))
'((sbcl-1.0.52-x86-64-darwin ("sbcl"))
(lw60-macosx-x86 ("../../common/lw60-macosx-x86/lw-console"))))
((and (string= (getenv "cl_platform") "Allegro")
(string= (getenv "os_platform") "Linux"))
'((acl82m-linux-x86 ("../../common/acl82-linux-x86/mlisp"))
(acl82a-linux-x86 ("../../common/acl82-linux-x86/alisp"))
(sbcl-1.0.50.0.debian ("sbcl"))))
((and (string= (getenv "cl_platform") "SBCL")
(string= (getenv "os_platform") "Linux"))
'((sbcl-1.0.50.0.debian ("sbcl"))
(acl82m-linux-x86 ("../../common/acl82-linux-x86/mlisp"))
(acl82a-linux-x86 ("../../common/acl82-linux-x86/alisp"))))
(t (error (concat "Unknown OS/Lisp combination: "
(getenv "os_platform")
(getenv "cl_platform"))))))
(slime-setup '(slime-fancy))
(defun gdl () (interactive) (slime ))
(setq gdl:*gdl-toplevel* (concat "*" "slime-repl " (symbol-name (first (first slime-lisp-implementations))) "*"))
(setq gdl:*inferior-lisp* "*inferior-lisp*")
(require 'slime-autoloads)
(eval-after-load "slime"
'(progn
(add-to-list 'load-path "/usr/local/slime/contrib")
(slime-setup '(slime-fancy slime-banner))
(setq slime-complete-symbol*-fancy t)
(setq slime-complete-symbol-function 'slime-fuzzy-complete-symbol)))
(global-set-key "\C-x&" '(lambda()(interactive) (switch-to-buffer gdl:*gdl-toplevel*)))
(global-set-key "\C-x*" '(lambda()(interactive) (switch-to-buffer gdl:*inferior-lisp*)))
(global-set-key "\C-xy" '(lambda() (interactive) (other-window -1)))
;;
;; FLAG -- comment the following if you want a tool bar.
;; (errors ignored in case running in a console terminal)
(ignore-errors (tool-bar-mode -1))
(setq visible-bell t)
;;
;; FLAG -- uncomment the following if you don't need a menu bar.
;; (errors ignored in case running in a console terminal)
;;
;;(ignore-errors (menu-bar-mode -1))
;;
;; Use M-x clear-kill-ring in case you have too much garbage in the
;; kill ring
;;
(defun clear-kill-ring () (interactive) (setq kill-ring nil))
;;
;; FLAG -- you can customize default GDL emacs colors here.
;;
(defun gdl:set-colors ()
(interactive)
(progn
(set-foreground-color "white")
(set-background-color "midnight blue")
(setq default-frame-alist (append default-frame-alist '((background-color . "midnight blue"))))
(set-face-foreground 'default "white")
(set-face-foreground 'font-lock-type-face "hotpink")
(set-face-foreground 'font-lock-keyword-face "Cyan")
(set-face-foreground 'font-lock-string-face "#88FFAA")
(set-face-foreground 'font-lock-function-name-face "#55ff88")
(set-face-foreground 'font-lock-comment-face "#888888")
(set-face-foreground 'font-lock-builtin-face "#ffff99")
(add-to-list 'default-frame-alist '(cursor-color . "RosyBrown4"))
(set-cursor-color "#55FFFF")))
;; ignore errors when setting colors in case of running in console
;; terminal (there's probably a better way to test for this).
(ignore-errors (gdl:set-colors))
(defun gdl:set-font ()
(interactive)
(ignore-errors (set-frame-font "-bitstream-Courier 10 Pitch-normal-normal-normal-*-*-*-*-*-m-0-iso10646-1")))
(gdl:set-font)
(show-paren-mode t)
(defun add-gdl-font-lock-keywords ()
(let ((definition-keywords
(regexp-opt (list "define-object-amendment" "define-object" "define-view" "define-lens" "define-format" "define-skin"
"defpart" "defwriter" "defcompanion" "write-the-object" "write-the"
"the " "the-child" "the-object" "the-element" ) t))
(keyword-keywords
(regexp-opt (list ":documentation"
":input-slots" ":computed-slots" ":objects" ":hidden-objects" ":functions" ":methods"
":output-functions" ":skin" ":trickle-down-slots" ":type" ":sequence"
":size" ":parameters" ":pass-down" ":inputs" ":optional-inputs"
":modifiable-optional-inputs" ":descendant-attributes" ":attributes"
":parts" ":pseudo-parts" ":methods") t)))
(pushnew (list definition-keywords 0 font-lock-keyword-face) lisp-font-lock-keywords)
(pushnew (list keyword-keywords 0 font-lock-type-face) lisp-font-lock-keywords)))
(add-gdl-font-lock-keywords)
(defmacro defindent (name indentation)
(let* ((keyword-list '(lisp-font-lock-keywords t t t nil nil nil "&allow-other-keys"))
(spec (if (eq indentation 'gdl-object-style) `((1 t ,keyword-list) (0 t 2)) indentation)))
`(put ',name 'lisp-indent-hook ',spec)))
(defun gdl:define-indents ()
(defindent define-object gdl-object-style)
(defindent define-view (like define-object))
(defindent define-format (like define-object))
(defindent defpart (like define-object))
(defindent defwriter (like define-object))
(defindent defcompanion (like define-object)))
;;
;; From EvW
;;
(setq next-line-add-newlines nil)
(defun ISO-current-time-string ()
(format-time-string "%Y-%m-%dT%T%z"))
(defun EvW-insert-date ()
"time and date function suggested by Tom Capey (2000-11-28T19:21:04+0100)"
(interactive)
(insert (ISO-current-time-string)))
(defun EvW-save-and-kill-buffer (bufname)
"Saves current buffer, then kills it"
(interactive "b")
(let ((cb (current-buffer)))
(save-buffer cb)
(kill-buffer cb)))
(global-set-key "\M-t" 'EvW-insert-date)
(global-set-key "\C-x\C-k" 'EvW-save-and-kill-buffer)
(defvar font-lock-maximum-decoration t)
(global-font-lock-mode t)
(add-hook 'write-file-hooks 'time-stamp)
(defvar time-stamp-active t)
(defvar time-stamp-format "%3a, %:y-%02m-%02dT%02H:%02M:%02S -- %f")
;; if you encounter a file with ^M or ... at the end of every line,
;; this means a worng copy by samba or floppy disk of the DOS file to UNIX.
;; get rid of them by pressing [F5].
(defun cut-ctrlM ()
(interactive)
(goto-char (point-min));(beginning-of-buffer)
(while (search-forward "\r" nil t)
(replace-match "" nil t))
(not-modified)
(goto-char (point-min)))
(defun replace-ctrlM (ch) ;2001-04-17T17:46:41+0200
(interactive)
"Replace all visible ^M with argument (defaulting to the empty string.)"
(goto-char (point-min))
(while (search-forward "\r" nil t)
(replace-match ch nil t))
;;(not-modified)
(goto-char (point-min)))
(defun remove-trailing-whitespace ()
"Removes trailing blanks and tabs from the buffer."
(interactive)
(save-excursion ;let deactivate-mark nil?
(goto-char (point-min))
(while (re-search-forward "[ \t]+$" nil t)
(replace-match "" nil nil))))
(defun tidy-up ()
"Removes trailing whitespace and ^M from the end of lines.
Bug: does not leave point at the position it had when the function was called"
(interactive)
(save-excursion
(let ((curpos (point)))
(cut-ctrlM)
(remove-trailing-whitespace)
(goto-char curpos))))
;;; EOF
(in-package :common-lisp-user)
(load "~/Genworks-GDL/load.lisp")
\ No newline at end of file
(setq next-line-add-newlines nil)
(require 'cl)
;;
;; EvW's prefs
;; To do:
;; - (EvW-save-and-kill-buffer) make argument work sensibly (?)
(defun ISO-current-time-string ()
(format-time-string "%Y-%m-%dT%T%z"))
(defun EvW-insert-date ()
"time and date function suggested by Tom Capey (2000-11-28T19:21:04+0100)"
(interactive)
(insert (ISO-current-time-string)))
;;;open a buffer for logging how my time is spent...
(find-file "~/src/CL/systems/timekeeper/data/uren.csv")
(goto-char (point-max))
(defun EvW-save-and-kill-buffer (bufname)
"Saves current buffer, then kills it"
(interactive "b")
(let ((cb (current-buffer)))
(save-buffer cb)
(kill-buffer cb)))
(defun insert-lisp-file-header (pkg)
"inserts a Lisp header, assuming the file is empty."
(insert ";;; -*- Mode: Lisp -*-")
(insert "\n\n(cl:in-package ")
(let ((pkg-char (point-max))) ;to check package-name later
(insert pkg ")\n\n") ;how to downcase pkg??
(insert ";;; Author: " user-full-name " <" user-mail-address ">\n")
(insert ";;; Created: " (ISO-current-time-string) " as " (buffer-name) "\n")
(insert ";;;Time-stamp: <>\n")
(insert ";;; Purpose:\n")
(insert ";;; To do:\n")
(insert ";;; Remarks:\n\n")
(insert ";;; EOF ")
(goto-char pkg-char)))
(defun find-lisp-file (fpath) ;add a file header when in Lisp-mode
"Finds (Lisp) file indicated and if empty, inserts Lisp comments."
(interactive "FFind (lisp) file: ") ;get file name if called in minibuffer
(let ((pkg ;use a sensible package
(cond ((boundp 'fi:package) fi:package)
((boundp 'fi:default-package) fi:default-package)
((fboundp 'slime-current-package)
(or (slime-current-package) ":cl-user"))
(t ":cl-user")))
(buf (find-file fpath)))
(set-buffer buf)
(when (and (= 0 (buffer-size))
(or (eq major-mode 'lisp-mode)
(eq major-mode 'slime-repl-mode)))
(insert-lisp-file-header pkg))
buf))
(global-set-key "\M-t" 'EvW-insert-date)
(global-set-key "\C-x\C-c" 'EvW-save-and-kill-buffer)
(global-set-key "\C-x\C-f" 'find-lisp-file)
(defvar font-lock-maximum-decoration t)
(global-font-lock-mode t)
(add-hook 'write-file-hooks 'time-stamp)
(defvar time-stamp-active t)
(defvar time-stamp-format "%3a, %:y-%02m-%02dT%02H:%02M:%02S -- %f")
;;; Western European character set (klopt geen reet van)!
;;(add-hook 'text-mode-hook '(lambda () (standard-display-european 1) ))
;;(add-hook 'text-mode-hook '(lambda () (iso-accents-mode 1) ))
(custom-set-faces)
;;; Jim Traugott [traugott@iname.com] -- 2000-02-29T23:42:55
;;; Set the frame's title. %b is the name of the buffer. %+ indicates the
;;; state of the buffer: * if modified, % if read only, or - otherwise. Two
;;; of them to emulate the mode line. %f for the file name.
(setq frame-title-format "Emacs: %b %+%+ %f")
(setq icon-title-format "Emacs - %b")
;;;(require 'eol-conversion) ;remove this for Emacs 21.2?
;;;Playing around with colors
;;;(set-face-foreground 'highlight "black")
(set-face-background 'highlight "green")
;;;(set-face-foreground 'region "black")
(set-face-background 'region "green")
;;;(set-face-foreground 'secondary-selection "antiquewhite1")
(set-face-background 'secondary-selection "Yellow")
(setq-default search-highlight t)
(copy-face 'highlight 'isearch)
(setq-default query-replace-highlight t)
;;;but John ffitch likes these
(custom-set-faces
'(my-tab-face ((((class color)) (:background "lemon chiffon"))) t)
'(my-trailing-space-face ((((class color)) (:background "Gold"))) t))
(defvar font-lock-keywords)
(add-hook 'font-lock-mode-hook
(function
(lambda ()
(setq font-lock-keywords
(append font-lock-keywords
'(("\t+" (0 'my-tab-face t))
("[ \t]+$" (0 'my-trailing-space-face t))))))))
;;;(add-hook 'dired-load-hook
;;; (lambda () (require 'dired-sort-menu)))
;;;highlight during isearch!
;;;(require 'ishl)
;;;(ishl-mode t)
;;;(setq-default ishl-cleanup nil)
;; if you encounter a file with ^M or ... at the end of every line,
;; this means a worng copy by samba or floppy disk of the DOS file to UNIX.
;; get rid of them by pressing [F5].
(defun cut-ctrlM ()
(interactive)
(goto-char (point-min));(beginning-of-buffer)
(while (search-forward "\r" nil t)
(replace-match "" nil t))
(not-modified)
(goto-char (point-min)))
(defun replace-ctrlM (ch) ;2001-04-17T17:46:41+0200
(interactive)
"Replace all visible ^M with argument (defaulting to the empty string.)"
(goto-char (point-min))
(while (search-forward "\r" nil t)
(replace-match ch nil t))
;;(not-modified)
(goto-char (point-min)))
(defun remove-trailing-whitespace ()
"Removes trailing blanks and tabs from the buffer."
(interactive)
(save-excursion ;let deactivate-mark nil?
(goto-char (point-min))
(while (re-search-forward "[ \t]+$" nil t)
(replace-match "" nil nil))))
(defun tidy-up ()
"Removes trailing whitespace and ^M from the end of lines.
Bug: does not leave point at the position it had when the function was called"
(interactive)
(save-excursion
(let ((curpos (point)))
(cut-ctrlM)
(remove-trailing-whitespace)
(goto-char curpos))))
;;; EOF
\ No newline at end of file
(in-package :common-lisp-user)
(asdf:defsystem #:gdl-all
:description "The Genworks GDL full system."
:author "Dave Cooper <david.cooper@genworks.com>"
:license "AGPL"
:serial t
:version "2011100200"
:depends-on (
:gdl-gwl-graphics
:depends-on (:gdl-gwl-graphics
:gdl-ta2
:gdl-tasty
:gdl-demos
......
;;
;; Copyright 2002, 2009 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl-user)
(define-object tatu-test (gwl:base-html-sheet)
:computed-slots
((list-test '(:a36 nil nil "W3b") :settable)
(nil-test nil :settable)
(keyword-test :a36 :settable)
(string-test "hello" :settable)
(number-test 45 :settable)))
(in-package :gwl-user)
(define-object tatu-children (base-html-sheet)
:computed-slots
((length 1 :settable)
(width 2 :settable)
(height 3 :settable)
(aapple (i-dont-know-how 1 2 3))
)
;; It would be great to be able to see kids 1-3 even though 4 can't appear. Then you can use
;; tatu to help track down the error that feeds kid-4's part type.
:objects
((kid-1 :type 'my-box
:pass-down (:length :width :height))
(kid-2 :type 'my-box
:pass-down (:length :width :height))
(kid-3 :type 'my-box
:pass-down (:length :width)
:height (error "This will cause all of the children not to appear This will cause all of the children not to appear This will cause all of the children not to appear This will cause all of the children not to appear This will cause all of the children not to appear"))
(kid-4 :type (if (> (the kid-3 volume) 10)
'my-box
'box)
:pass-down (:length :width :height))
(kid-5 :type 'my-box
:sequence (:size 5)
:display-controls (if (= (the-child index) 4)
(error "Can't compute display-controls")
(list :color :green))
:strings-for-display (if (= (the-child index) 3)
(error "Can't compute strings-for-display")
(format nil "kid-5 ~a" (the-child index))))
(kid-6 :type 'tatu-children)
))
(define-object my-box (box))
(define-object draw-error (base-object)
:objects
((box :type 'box
:height 20
:width 10
:length 10
:display-controls (list :color :green)
:center (translate (the center) :left 25))
(box-1 :type 'box
:height 1 ;;(/ 1 0)
:width 10
:length 10)))
(define-object measure-distance (base-object)
:objects
((left-box :type 'box
:display-controls (list :color :red)
:length 10 :width 20 :height 30
:center (translate (the center) :left 100))
(left-center-box :type 'box
:display-controls (list :color :orange)
:length 10 :width 20 :height 30
:center (translate (the center) :left 50))
(right-box :type 'box