[Openmcl-devel] FScript contribution

[Joerg Garbers]

Hi,
- Writing scripts for Cocoa classes is very easily done in FScript (see 
http://www.fscript.org).
- I find the reader macros for cocoa very useful, but still a little 
difficult to read.
- FScript comes as dynamic library (FScript.framework) with a lot of 
goodies and documentation.
- So why not connecting OpenMCL and FScript to call FScript from 
OpenMCL and vice versa?
This is done in the file attachment.

Joerg

BTW:
1. Whoever wrote the cocoa examples, thanks a lot!
2. Does anybody know, if the commercial MCL supports cocoa classes 
(windows etc.) too?

fscript.lisp (to be put into the ccl/examples folder):

;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   file: fscript.lisp
;;;
;;;   Copyright (C) 2003 Joerg Garbers
;;;   You may use this code under the  terms of the Lisp Lesser GNU 
Public
;;;   License.
;;;
;;;   Purpose: provide helper functions for connecting OpenMCL and 
FScript
;;;            enabling to call FScript from OpenMCL and vice versa
;;;
;;;   Background:
;;;            FScript is an OpenSource scripting language for Cocoa.
;;;            See http://www.fscript.org (Philippe Mougin).
;;;            FScript.framework must be installed in 
/Library/Frameworks
;;;            or change the open-shared-library line.
;;;
;;;   Reason:
;;;            FScript allows to write interpreted Cocoa code more
;;;            readable and fault tolerant.
;;;            (See examples at the end of this file.)
;;;
;;;            This bridge might also be very interesting to FScript 
users,
;;;            because OpenMCL allows to access standard c functions, 
which
;;;            are not accessible in FScript.
;;;
;;;
;;; Most interesting exported functions:
;;;
;;; (fs-eval "script") -> lisp string
;;; (fs-result "script") -> c pointer (id)
;;; -[System lisp:(NSString *)]
;;;

(in-package "CCL")

(require "cocoa")
;or, if AppKit is not needed: (require "cocoa-window") 
(create-autorelease-pool)

(eval-when (:compile-toplevel :execute)
   (setq *readtable* *objc-readtable*))

;;; load FScript.framework
(open-shared-library "/Library/Frameworks/FScript.framework/FScript")
;;; or load FScript Anywhere by hand (must be launched after require 
cocoa)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Accessing FScript from LISP ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; create an FScript interpreter
;; without own user interface
(defun new-fs-interpreter ()
   [(@class "FSInterpreter") "setup" :void]
   [[(@class "FSInterpreter") "alloc"] "init"])
;; using FSAController (when FScript Anywhere was applied to 
OpenMCL.app)
(defun new-fsa-interpreter ()
   (let* ((fsacontroller [[(@class "FSAController") "alloc"] "init"]))
      [[[fsacontroller "interpreterView"] "interpreter"] "retain"]))

;;; global FScript interpreter reference
(defvar *fsinterpreter* nil)
(setf *fsinterpreter* (new-fs-interpreter))

;;; evaluates script (a lisp string) returning an FSInterpreterResult 
object
(defun fs-result (script &optional (fs-interpreter *fsinterpreter*))
   (let ((result [fs-interpreter "execute:" :id (%make-nsstring 
script)]))
     (if (= [result "isOk" :<BOOL>] #$YES)
       [result "result"]
       (error (concatenate 'string "fs-result: FSInterpreter error 
message:" (%get-cstring [[result "errorMessage"] "cString" :address]) " 
for sent Script: " script)))))

;;; evaluates script (a lisp string) returning a lisp string
(defun fs-eval (script &optional (fs-interpreter *fsinterpreter*))
   (let ((result-id (fs-result script fs-interpreter)))
      (if (%null-ptr-p result-id) "nil"
         (let ((c-string [[result-id "description"] "cString" :address]))
            (if (%null-ptr-p c-string) (error "Cocoa error: object did 
not return proper description")
              (%get-cstring c-string))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Accessing LISP from FScript ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; there is an instance of class System called "sys" in every FScript 
interpreter environment
(def-objc-class "System" "NSObject"
   sys)

(define-objc-method ("lisp:" "System")
     (:id string :id)
   (let* ((c-string [string "cString" :address])
          (lisp-string (%get-cstring c-string))
;         (reply-string (concatenate 'string lisp-string "done"))
          (reply-string (princ-to-string (eval (read-from-string 
lisp-string))))
          (reply-nsstring (%make-nsstring reply-string)))
      reply-nsstring))

#|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Testing                     ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require "fscript")
(in-package "CCL")
(setq *readtable* *objc-readtable*)

;; FScript from Lisp
(fs-eval "w:=5+2")
(fs-eval "w")
(fs-eval "[w := NSWindow alloc initWithContentRect:(100<>100 
extent:300<>300) styleMask:NSTitledWindowMask+NSClosableWindowMask 
backing:NSBackingStoreBuffered defer:false.w orderFront:nil] value")

;; This graphic animation must be evaluated in the listener window
;; (not in the terminal window!)
;; The FScript Code is stolen from the FScript tutorial.
(fs-eval "
keyWindow := NSApplication sharedApplication keyWindow.
NSBezierPath setDefaultLineWidth:20.
keyWindow contentView lockFocus.
1 to:550 by:4 do:
[:x|
path := NSBezierPath bezierPathWithOvalInRect:(x<>130 extent:200 
-(x/3)<>(x/2)).
(NSColor colorWithDeviceRed:x/570 green:0.1 blue:1 -(x/570) alpha:1) 
set.
path stroke.
keyWindow flushWindow.
NSColor whiteColor set.
path setLineWidth:path lineWidth + 2.
path stroke.
].
keyWindow contentView unlockFocus.
keyWindow display.
")

;; embed a Lisp call into a FScript call
(fs-eval "'a' ++ (sys lisp:'\"b\"')")

;;; recursive calling test
;; define FScript function fac in FScript environment.
;; it calls Lisp recursively
(fs-eval "fac:=[:n | (n isEqual:0) ifTrue:[1] ifFalse:[n*((sys 
lisp:('(fac ' ++ (n-1) ++ ')')) intValue)]].")
;; define Lisp function fac
;; it calls FScript
(defun fac (n)
   (if (= n 0) 1 (* n (read-from-string (fs-eval (concatenate 'string 
"fac value:" (princ-to-string (- n 1))))))))

;; note, that FScript uses 32 bit integers, so the result is not 
correct for large numbers.
(fac 20)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Performance                 ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; for performance tests: a comparable lisp function, which includes
;; an equal amount of actions:
;; interpreter actions: (read, eval)
;; string manipulations: construct call for n-1,
;;    call (other) interpreter
;;    decode result string
(defun fac-lisp (n)
   (if (= n 0) 1 (* n (read-from-string (princ-to-string (eval 
(read-from-string (concatenate 'string "(fac-lisp " (princ-to-string (- 
n 1)) ")"))))))))
(defun fac-lisp-plain (n)
   (if (= n 0) 1 (* n (fac-lisp-plain (- n 1)))))

(setq n 100)
(time (fac n))
(time (fac-lisp-plain n))
(time (fac-lisp n))
(time (fac n))
;; the durations are aproximately equal.
;; note that lisp does long integer arithmetic which takes also some 
time
;; and that without string operations fac-lisp-plain is much! faster
;; but of cause, we do not need Cocoa or Lisp to do the basic 
arithmetic functions, do we?

; these numbers are feasable on a 866 MHz G4 (between 0.1 and 1 seconds)
(time (dotimes (x 100000000) (list "42")))
(time (dotimes (x 1000000) (eval "42")))
(time (dotimes (x 100000) (eval (read-from-string "42"))))
(time (dotimes (x 1000) (fs-eval "42")))
(time (dotimes (x 1000) (fs-eval "[:x |'42'] value:1. nil")))
(time (fs-eval "[:x |'42'] value:@(10000 iota). nil"))
(let ((block (fs-result "[:x |'42']"))
       (arg (fs-result "1.0")))
   (time (dotimes (x 10000) [block "value:" :id arg])))
|#


_______________________________________________
Openmcl-devel mailing list
Openmcl-devel at clozure.com
http://clozure.com/cgi-bin/mailman/listinfo/openmcl-devel