Commit 8001f973 authored by Dave Cooper's avatar Dave Cooper

removed site and site-static for factoring and overhaul

parent 093aa360
;;
;; Copyright 2002-2011, 2012 Genworks International
;;
;; 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 :www.genworks.com)
(define-object services (base-site-sheet)
:computed-slots
((title "Genworks International - Services")
(link-title "Services")
(right-section-inner-html
(with-cl-who-string ()
(:H2 "Our Services") ((:DIV :ID "welcome"))
((:DIV :ID "profile")
((:DIV :ID "peop") (:H3 "Value-added application support ")
(:P
"One year Maintenance and Implementation Support (provided by KE-Works, up to 5 events), with the option to renew at any time for a 5 k&euro; fee.")
(:H3 "Remote consultancy ")
(:P "Service scheduled for release Q1 2012.")
(:H3 "On-site consultancy ")
(:P "Service scheduled for release Q1 2012.")))))))
\ No newline at end of file
;;
;; Copyright 2002-2011, 2012 Genworks International
;;
;; 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 :www.genworks.com)
(define-object assembly (base-site-sheet)
:computed-slots
((title "Genworks International - Welcome")
(lang (the language choice value))
(right-section-inner-html (the current-right-section right-section-inner-html))
(right-section-js-to-eval (the current-right-section right-section-js-to-eval))
(right-section-js-always-to-eval (the current-right-section right-section-js-to-eval))
(link-title "Home")
(pages (the children)))
:trickle-down-slots (pages lang)
:hidden-objects
((news :type 'news)
(primi-plane :type 'gdl-user::primi-plane)
(robot :type 'robot:assembly))
:objects
((index-html :type 'index-html
:respondent self)
(products :type 'products
:respondent self)
;;(services :type 'services)
(documentation :type 'documentation-and-educational
:respondent self)
(demos :type 'demos
:respondent self)
(downloads :type 'downloads
:respondent self)
(people :type 'people
:respondent self)
(contact-us :type 'contact-us
:respondent self)
(language :type 'language
:respondent self)
))
\ No newline at end of file
;;
;; Copyright 2002-2011, 2012 Genworks International
;;
;; 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 :www.genworks.com)
(define-object configurator (base-site-sheet)
:computed-slots
((link-title "Configurator")
(right-section-js-to-eval "hide_all();$j('#product-image').show(200);")
(right-section-inner-html (with-cl-who-string ()
((:a :name "Top"))
(:h1 "Estimated Pricing: $" (fmt "~:d" (ceiling (the current-price))))
(str (the current-choice-screen inner-html))
(str (the summary inner-html))
(when (the current-choice-screen explanation-html)
(htm (:p
(str (the current-choice-screen explanation-html)))))
))
;;
;; FLAG -- figure out how to make this whole thing into an object tree instead of this hairy-calc.
;;
(current-price
(+ (the gendl-license selected-price)
(the cl-engine selected-price)
(the geometry-kernel selected-price)
(the support-level selected-price)
(the training-level selected-price)))
(current-choice-screen (the gendl-license) :settable)
(selected-gendl-license (the gendl-license choice value))
(selected-cl-engine (the cl-engine choice value))
(selected-geometry-kernel (the geometry-kernel choice value))
(selected-support-level (the support-level choice value))
(selected-training-level (the training-level choice value))
(academic? (the gendl-license academic-input? value))
(set-current-sheet-function #'(lambda(sheet)
(the (set-slot! :current-choice-screen sheet))))
)
:trickle-down-slots (respondent set-current-sheet-function)
:objects
((gendl-license :type 'gendl-license-choice
:pass-down (selected-gendl-license
selected-cl-engine selected-geometry-kernel selected-support-level
selected-training-level academic?)
:next-sheet (the cl-engine))
(cl-engine :type 'cl-engine-choice
:pass-down (selected-gendl-license
selected-cl-engine selected-geometry-kernel selected-support-level
selected-training-level academic?)
:previous-sheet (the gendl-license)
:next-sheet (the geometry-kernel))
(geometry-kernel :type 'geometry-kernel-choice
:pass-down (selected-gendl-license
selected-cl-engine selected-geometry-kernel selected-support-level
selected-training-level academic?)
:previous-sheet (the cl-engine)
:next-sheet (the support-level))
(support-level :type 'support-level-choice
:pass-down (selected-gendl-license
selected-cl-engine selected-geometry-kernel selected-support-level
selected-training-level academic?)
:previous-sheet (the geometry-kernel)
:next-sheet (the training-level))
(training-level :type 'training-level-choice
:pass-down (selected-gendl-license
selected-cl-engine selected-geometry-kernel selected-support-level
selected-training-level academic?)
:previous-sheet (the support-level))
(summary :type 'quotation-summary
:selected-items (list (the gendl-license selected-item)
(the cl-engine selected-item)
(the geometry-kernel selected-item)
(the support-level selected-item)
(the training-level selected-item))
:current-total (the current-price))))
(define-object quotation-summary ()
:input-slots (selected-items current-total)
:computed-slots
((inner-html (with-cl-who-string ()
((:div :class "quotation-summary")
(:table
(:tr (:th (str (locale-string :gendl-component)))
(:th (str (locale-string :your-selection)))
(:th (str (locale-string :price))))
(dolist (item (the selected-items))
(htm (:tr ((:td :class "clickme") (str (the-object item go-to-link)))
(:td (str (the-object item string)))
((:td :class "right-justify")
(fmt "$~:d" (ceiling (the-object item selected-price)))))))
(:tr (:th :br) ((:th :class "right-justify") "Total")
((:td :class "look-at-me right-justify") (fmt "$~:d" (the current-total))))))))))
(define-object wizard-screen (sheet-section)
:input-slots ((previous-sheet nil) (next-sheet nil) (extra-controls-html nil)
set-current-sheet-function
selected-gendl-license selected-cl-engine selected-geometry-kernel
selected-support-level selected-training-level academic?
(discount-func (if (the academic?)
#'(lambda(num) (half num))
#'identity))
(explanation nil) ;; override with child object
(explanation-html (when (and (the explanation)
(typep (the explanation) 'sheet-section))
(the explanation inner-html))))
:computed-slots ((inner-html (with-cl-who-string ()
(:p
(:h2 (str (the heading)))
(:fieldset
(str (the choice html-string))
(when (the extra-controls-html)
(str (the extra-controls-html)))))
(when (the money-saving-tip)
(htm ((:p :class "helpful-tip")
(str (locale-string :tip)) ": " (str (the money-saving-tip)))))
(:p
(when (the previous-sheet)
(str (the previous-button form-control-string)))
(when (the next-sheet)
(str (the next-button form-control-string))))))
(current-choice-object self)
(selected-price (the selected-item current-price))
(radio-price-choices (remove-if-not #'(lambda(child) (typep child 'radio-price-choice))
(the children)))
(choice-plist
(mapcan #'(lambda(radio)
(list (make-keyword (the-object radio strings-for-display))
(the-object radio choice-price-string)))
(the radio-price-choices)))
(selected-item (dolist (object (the radio-price-choices))
(when (eql (the-object object key) (the choice value))
(return object))))
(money-saving-tip nil)
)
:trickle-down-slots (selected-item selected-price heading current-choice-object)
:objects ((previous-button :type 'button-form-control
:label (format nil "&lt;-~a" (locale-string :previous))
:onclick (the (gdl-ajax-call :function-key :set-current-sheet
:arguments (list (the previous-sheet)))))
(next-button :type 'button-form-control
:label (format nil "~a-&gt;" (locale-string :next))
:onclick (the (gdl-ajax-call :function-key :set-current-sheet
:arguments (list (the next-sheet)))))
(choice
:type 'radio-form-control
:choice-plist (the choice-plist)
:prompt ""
:default (make-keyword (the default strings-for-display))
:disabled-keys nil
:disabled-keys
(remove-if-not #'(lambda(key) (the (evaluate key) disabled?))
(plist-keys (the-child choice-plist)))
:ajax-submit-on-change? t
))
:functions
((set-current-sheet
(sheet)
(funcall (the set-current-sheet-function) sheet))))
(define-object radio-price-choice (sheet-section)
:input-slots (string current-price (disabled? nil) (disabled-message "") heading current-choice-object)
:computed-slots ((key (make-keyword (the strings-for-display)))
(selected? (eql (the selected-item) self))
(delta (- (the current-price) (the selected-price)))
(go-to-link (let ((choice-object (the current-choice-object)))
(with-cl-who-string ()
((:span :onclick (the (gdl-ajax-call
:function-key :set-current-sheet
:arguments (list choice-object))))
(str (the heading))))))
(choice-price-string
(if (the disabled?)
(with-cl-who-string()
((:span :class "disabled") (str (the string)))
" "
(unless (string-equal (the disabled-message) "")
(htm :br "&nbsp;" (:i (str (the disabled-message))))))
(format nil "~a ~a" (the string)
(if (the selected?) "" (format nil "(~a$~:d)"
(cond ((zerop (the delta)) "+")
((plusp (the delta)) "+")
((minusp (the delta)) "-"))
(abs (ceiling (the delta)))))))))
:functions ((set-current-sheet (object)
(funcall (the set-current-sheet-function) object))))
;;
;; Copyright 2002-2011, 2012 Genworks International
;;
;; 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 :www.genworks.com)
(defun info-anchor (string)
(with-cl-who-string ()
((:a :href (format nil "#~a" string))
((:img :src "/newsite-static/images/information.png" :width 12)))))
(define-object gendl-license-choice (wizard-screen)
:computed-slots ((heading (locale-string :gendl-licensing-level))
(default (the agpl))
(extra-controls-html (with-cl-who-string ()
(str (the academic-input? html-string)))))
:objects
((agpl :type 'radio-price-choice
:string (string-append (locale-string :open-source-agpl)
(info-anchor "agpl-license"))
:disabled? (eql (the selected-geometry-kernel) :smlib)
:disabled-message (locale-string :please-select-basic-geom)
:current-price 0)
(trial :type 'radio-price-choice
:string (string-append (locale-string :evaluation)
(info-anchor "trial-license"))
:current-price 0)
(student :type 'radio-price-choice
:string (string-append (locale-string :student)
(info-anchor "student-license"))
:current-price 49)
(professional :type 'radio-price-choice
:string (string-append (locale-string :professional)
(info-anchor "professional-license"))
:current-price (funcall (the discount-func) 1990))
(enterprise :type 'radio-price-choice
:string (string-append (locale-string :enterprise)
(info-anchor "enterprise-license"))
:current-price (funcall (the discount-func) 4990))
(academic-input? :type 'checkbox-form-control
:ajax-submit-on-change? t
:default (eql (the selected-gendl-license) :student)
:label-position :table-td-append
:prompt (string-append (locale-string :order-qualifies-for-academic)
(info-anchor "academic-pricing")))
(explanation :type 'license-choice-explanation)))
(define-object cl-engine-choice (wizard-screen)
:computed-slots ((heading (locale-string :common-lisp-engine))
(default (case (the selected-gendl-license)
(:agpl (the none))
(:professional (the lw-32-base))
(otherwise (the acl-32))))
(lw-uplift 1)
(acl-uplift 1)
(discount-func #'(lambda(price key)
(ecase key
(:none price)
(:sbcl price)
(:acl-32 (* (the acl-uplift) price))
(:acl-64 (* (the acl-uplift) price))
(:lw-32-base (* (the lw-uplift) price))
(:lw-32-full (* (the lw-uplift) price))
(:lw-64-full (* (the lw-uplift) price))))))
:objects
((none :type 'radio-price-choice
:string (string-append (locale-string :none) " ("
(locale-string :i-e) (locale-string :space)
(locale-string :self-provided-or-third-party) ")")
:current-price (funcall (the discount-func) 0 (first (the-child root-path)))
:disabled? (or (eql (the selected-geometry-kernel) :smlib)
(eql (the selected-gendl-license) :trial)
(not (eql (the selected-support-level) :none)))
:disabled-message (format nil "~a ~a~a~a~a~a ~a."
(locale-string :please-select)
(if (eql (the selected-geometry-kernel) :smlib)
(locale-string :the-basic-geometry-kernel) "")
(cond ((and (eql (the selected-geometry-kernel) :smlib)
(eql (the selected-gendl-license) :trial))
(string-append (locale-string :space) (locale-string :and) (locale-string :space)))
(t (locale-string :space)))
(if (eql (the selected-gendl-license) :trial)
(locale-string :a-non-evaluation-gendl-license) "")
(cond ((and (not (eql (the selected-support-level) :none))
(or (eql (the selected-gendl-license) :trial)
(eql (the selected-geometry-kernel) :smlib)))
(string-append (locale-string :space) (locale-string :and) (locale-string :space)))
((not (eql (the selected-support-level) :none))
(locale-string :space))
(t ""))
(if (not (eql (the selected-support-level) :none))
(string-append "\"" (locale-string :none) "\""
(locale-string :space)
(locale-string :for)
(locale-string :space)
(locale-string :technical-support-level))
"")
(locale-string :to-enable-this-option )))
(sbcl :type 'radio-price-choice
:string "SBCL"
:current-price (funcall (the discount-func) 0 (first (the-child root-path)))
:disabled? (or (eql (the selected-geometry-kernel) :smlib)
(eql (the selected-gendl-license) :trial))
:disabled-message (the none disabled-message))
(acl-32 :type 'radio-price-choice
:string (locale-string :franz-allegro-cl-32)
:current-price
(funcall (the discount-func)
(ecase (the selected-gendl-license)
(:agpl (if (the academic?) 4500 6000))
(:trial 0)