Commit e5ab20c5 authored by Dave Cooper's avatar Dave Cooper

added actual files i hope

parent 98ea0615
This diff is collapsed.
(asdf:defsystem #:gdl-build :description
"Auto-generated asdf defsys from Genworks GDL cl-lite."
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :serial t
:version "2011101800" :depends-on (:gdl-base)
:components
((:file "source/package") (:file "source/genworks")
(:file "source/make-gdl-app")))
\ No newline at end of file
("package" "genworks")
(in-package :com.genworks.lisp)
(eval-when (compile load eval)
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:export #:make-gdl-app
#:delete-directory-and-files
)))
#-allegro(warn "~&Please implement generate-application for the currently running lisp.~%")
(defun make-gdl-app (&rest args)
#+allegro
(let ((app-name (getf args :application-name))
(target (getf args :destination-directory))
(modules (append (list :asdf :compftype :aserve :phtml)
(getf args :modules)))
(args (normalize-generate-application-args args)))
(apply #'excl:generate-application app-name target modules args))
#-allegro (declare (ignore args))
#-allegro (error "~&generate-application is not implemented for the currently running lisp.~%"))
#+allegro
(defun normalize-generate-application-args (args)
(let ((class (getf args :application-class)))
(list :runtime (case class
(:development :partners)
(otherwise nil))
:include-compiler (case class
(:development t)
(otherwise nil))
:include-devel-env (case class
(:development t)
(otherwise nil))
:icon-file (merge-pathnames "gdl/gwl/static/gwl/images/favicon.ico"
glisp:*genworks-source-home*)
:demo (getf args :demo-days)
;;:init-file-names (getf args :init-file-names)
:post-load-form (getf args :post-load-form)
:restart-init-function (getf args :restart-init-function)
:purify t
:autoload-warning nil
:runtime-bundle t
:suppress-allegro-cl-banner t)))
#-(or allegro (and unix lispworks))
(warn "~&Please implement delete-directory-and-files for the currently running lisp.~%")
(defun delete-directory-and-files (target &key force quiet if-does-not-exist)
#+lispworks (declare (ignore force quiet if-does-not-exist))
#+lispworks (system:run-shell-command (format nil "rm -rf ~a" target))
#+allegro (excl.osi:delete-directory-and-files
target :force force :quiet quiet :if-does-not-exist if-does-not-exist))
(in-package :gdl-build)
(defun make-gdl-app (&rest args)
(let ((self (apply #'make-object 'make-gdl-app args)))
(the make!)))
(define-object make-gdl-app ()
:input-slots
(("String. The name which will be used for your application's executable and dxl file.
Defaults to \"gdl-base.\""
application-name "gdl-base")
("Keyword symbol. Should be one of <tt>:runtime</tt>, <tt>:development</tt>, or <tt>:enterprise</tt>.
Indicates which level of application should be made. Defaults to :development."
application-class :development)
("Pathname. Indicates the directory to be created or overwritten for producing the distribution.
Defaults to a directory called <tt>(the application-name)</tt> in the user temporary directory,
returned by <tt>(glisp:temporary-folder)</tt>."
destination-directory
(merge-pathnames (make-pathname :directory (list :relative (the application-name)))
(glisp:temporary-folder) ))
;;
;; FLAG -- leave this to nil for now while we are working on the basic build.
;;
(post-load-form nil)
#+nil
(post-load-form `(progn (load ,(merge-pathnames "load.lisp" glisp:*genworks-source-home*))
(setf (symbol-value (read-from-string "glisp:*genworks-source-home*")) nil)
(setf (symbol-value (read-from-string "asdf:*central-registry*")) nil)))
;;
;; FLAG -- leave this to nil for now while we are working on the basic build.
;;
(init-file-names (list "gdlinit.cl" ".gdlinit.cl"))
(modules nil)
(demo-days 30)
)
:functions
((make!
()
(when (probe-file (the destination-directory))
(glisp:delete-directory-and-files (the destination-directory)))
(glisp:make-gdl-app :application-name (the application-name)
:destination-directory (the destination-directory)
:modules (the modules)
:post-load-form (the post-load-form)
:application-class (the application-class)
:demo-days (the demo-days)
;;
;; FLAG -- leave this to nil for now while we are working on the basic build.
;;
;;:init-file-names (the init-file-names)
;;:restart-init-function '(lambda() (gdl:start-gdl :edition :open-source))
))))
(in-package :gdl-user)
(gdl:define-package :gdl-build (:export #:make-gdl-app))
;;
;; 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/>.
;;
300,10,"yes"
300,3,"no"
400,7,"no"
300,30,"yes"
200,3,"no"
500,9,"no"
750,7,"no"
School Bus GDL/GWL Sample Application
=====================================
This is the original School Bus example and uses the old-style user
interface approach. It is not recommended to continue with this
approach; the preferred approach is to use form-control objects for
the form fields, as will be in other newer examples soon to be added
to the src/ directory distributed with GDL.
We hope to update it to use form-controls and AJAX at some
point. Currently it uses simple :settable computed-slots along with
explicit inline HTML forms and form fields (input tags), instead of
the more modern and preferred form-control objects
(e.g. text-form-control, menu-form-control, etc).
To compile the app
==================
Use cl-lite on the bus/ directory.
Once the application is compiled:
1. Make sure allegroserve is started with
(gwl:start-gwl)
2. Visit:
http://localhost:<port number>/demos/bus
;;
;; 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 :genworks.demos.bus)
(define-object assembly (node-mixin)
:input-slots
(
(strings-for-display "School Bus")
(wheelbase 300 :settable)
(track 96 :settable)
(height 80 :settable) (length 0) (width 0)
(turn-angle 0 :settable)
(number-of-rows 10 :settable)
(display-controls (list :vrml-navigation-info (list "speed" 5)
:vrml-viewpoints (list (list "position" (translate (the center) :up 500
:right (half (the wheelbase)))))))
(show-display-list? t)
(use-local-box? nil)
(use-standard-saved-slots? t)
)
:trickle-down-slots (:show-display-list?)
:objects
((body-frame-overhang :type 'body-frame-overhang-rule
:chassis-front-overhang (the chassis front-overhang)
:body-front-overhang (the body front-overhang))
(chassis :type 'chassis
:pass-down (wheelbase track turn-angle)
:datum (the center)
:height 20)
(body :type 'body
:pass-down (:wheelbase :track)
:frame-width (the chassis frame-width)
;;:frame-overhang (- (the-child front-overhang)
;;(the chassis front-overhang))
:firewall-base (translate
(the center) :up
(half (the chassis frame-height)) :right
(- (the-child cab-width)
(the-child body-frame-overhang result))))
(interior :type 'interior
:firewall-base (the body :firewall-base)
:width (- (the body width) (the body cab-width))
:length (the body length)
:height (the body height)
:number-of-rows (the number-of-rows)))
:hidden-objects
((axis-x :type 'box
:length 1 :width 100 :height 1)
(axis-y :type 'box
:length 100 :width 1 :height 1)
(axis-z :type 'box
:length 1 :width 1 :height 100)))
(define-object body-frame-overhang-rule (gwl-rule-object)
:input-slots (chassis-front-overhang body-front-overhang)
:computed-slots ((target-value 15)
(result (- (the body-front-overhang)
(the chassis-front-overhang)))
(rule-result (the result))
(rule-result-help "Computed by subtracting the front overhang
of the chassis from the front overhang of the body.")
(violated? (< (the result) (the target-value)))
(rule-description "Amount of overhang of body over axle")
(rule-title "Chassis Front Overhang")))
;;
;; 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 :genworks.demos.bus)
(define-object axle (base-object)
:input-slots
(kingpin-inclination-angle)
:computed-slots
((kingpin-vectors (list :left (the (:kingpins 0) (:face-normal-vector :front))
:right
(the (:kingpins 1) (:face-normal-vector :front)))))
:objects
((kingpins :type 'cylinder
:sequence (:size 2)
:radius 1.5
:length (the :height)
:center (the (:face-center (ecase (the-child :index) (0 :front) (1 :rear))))
:transformation-matrix
(alignment :front
(rotate-vector-d (the
(:face-normal-vector :top))
(funcall
(ecase
(the-child :index)
(0 #'identity)
(1 #'-))
(the
:kingpin-inclination-angle))
(the
(:face-normal-vector
:left))))
:orientation (the-child :transformation-matrix)
:display-controls (list :color :red))
(extrusion :type 'global-filleted-polygon-projection
:radius-list (list 5 5 5 5 1 1 5 5 5 5 1 1)
:projection-depth (the :width)
:projection-vector (the (:face-normal-vector :right))
:display-controls (list :color :blue-steel :shininess 7 )
:vertex-list
(let* ((d1 9)
(d2 8)
(d3 5)
(d4 7)
(top-edge
(let* ((a (the (:vertex :front :top :left)))
(b (translate a :rear d1))
(c (translate b :down d2 :rear d3))
(d
(translate c :rear
(- (the :length) (twice (+ d1 d3)))))
(e (translate d :up d2 :rear d3))
(f (translate e :rear d1)))
(list a b c d e f)))
(bottom-edge
(mapcar #'(lambda (point) (translate point :down d4))
top-edge)))
(append top-edge (nreverse bottom-edge))))))
;;
;; 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 :genworks.demos.bus)
(define-object body (application-mixin)
:input-slots
(wheelbase
track
firewall-base
frame-width)
:computed-slots
((ui-display-list-objects (the children))
(width (+ (the :wheelbase) (the :front-overhang) (the :rear-overhang)))
(rear-overhang 84 :settable)
(front-overhang 35 :settable)