home *** CD-ROM | disk | FTP | other *** search
/ ftp.sunet.sepub/pictures / 2014.11.ftp.sunet.se-pictures.tar / ftp.sunet.se / pub / pictures / ACiD-artpacks / programs / unix / editors / gimp-plugins-unstable-0_99_23_tar.gz / gimp-plugins-unstable-0_99_23_tar / gimp-plugins-unstable-0.99.23 / gimple / script-fu-compat.scm < prev   
Text File  |  1998-02-26  |  14KB  |  512 lines
  1. ;;;;     Copyright (C) 1998 Lauri Alanko <la@iki.fi>
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;; 
  18. ;;;; The GPL is also available at http://www.gnu.org/copyleft/gpl.html
  19.  
  20.  
  21. ; script-fu-compat.scm
  22.  
  23. (use-modules (toolkits gtk))
  24.  
  25. (debug-enable 'backtrace)
  26. (enum
  27.  SF-IMAGE
  28.  SF-DRAWABLE
  29.  SF-LAYER
  30.  SF-CHANNEL
  31.  SF-COLOR
  32.  SF-TOGGLE
  33.  SF-VALUE)
  34.  
  35. (enum
  36.  RGB_IMAGE
  37.  RGBA_IMAGE
  38.  GRAY_IMAGE
  39.  GRAYA_IMAGE
  40.  INDEXEDA_IMAGE)
  41.  
  42.  
  43. (define (color-widget default)
  44.   (define adjs (map (lambda (val) (gtk-adjustment-new val 0 255 1 1 0))
  45.             default))
  46.   (define scales (map gtk-hscale-new adjs))
  47.   (define labels (map gtk-label-new '("R" "G" "B")))
  48.   (define table (gtk-table-new 3 2 #f))
  49.   (define i 0)
  50.   (for-each (lambda (label scale)
  51.           (gtk-table-attach table label 0 1 i (1+ i) '() '())
  52.           (gtk-widget-show label)
  53.           (gtk-table-attach table scale 1 2 i (1+ i))
  54.           (gtk-scale-set-digits scale 0)
  55.           (gtk-widget-show scale)
  56.           (set! i (1+ i)))
  57.         labels
  58.         scales)
  59.   (define (getter)
  60.     (map (lambda (adj)
  61.        (inexact->exact (gtk-adjustment-value adj)))
  62.      adjs))
  63.   (cons table getter))
  64.  
  65.  
  66. (define (value-widget default)
  67.   (define entry (gtk-entry-new))
  68.   (gtk-entry-set-text entry default)
  69.   (define (getter)
  70.     (eval-string (gtk-entry-get-text entry)))
  71.   (cons entry getter))
  72.  
  73.  
  74. (define (toggle-widget default)
  75.   (define toggle (gtk-check-button-new))
  76.   (gtk-toggle-button-set-state toggle (not (zero? default)))
  77.   (define (getter)
  78.     (if (gtk-toggle-button-active toggle)
  79.     TRUE
  80.     FALSE))
  81.   (cons toggle getter))
  82.  
  83. (define (error-widget default)
  84.   (error "Sorry, drawable menus are not yet supported."))
  85.  
  86. (define argt
  87.   `((,SF-COLOR ,color-widget)
  88.     (,SF-VALUE ,value-widget)
  89.     (,SF-TOGGLE ,toggle-widget)
  90.     (,SF-IMAGE ,error-widget)
  91.     (,SF-DRAWABLE ,error-widget)
  92.     (,SF-CHANNEL ,error-widget)
  93.     (,SF-LAYER ,error-widget)))
  94.  
  95.  
  96. (define (run-script-interactive procname args)
  97.   (define procinfo (cddr (assoc procname sf-scriptdb)))
  98.   (define image-based (car procinfo))
  99.   (define arginfo (if image-based
  100.               (cdddr procinfo)
  101.               (cdr procinfo)))
  102.   (define imgargs
  103.     (if image-based
  104.     (params-to-sfargs (list-head args 2) (list-head (cdr procinfo) 2))
  105.     '()))
  106.   (define title (string-append "GimpleSF: " procname))
  107.   (define dlg (gtk-dialog-new))
  108.   (define (return) (gtk-main-quit)) 
  109.   (gtk-window-set-title dlg title)
  110.   (gtk-signal-connect dlg "destroy" return)
  111.  
  112.   (define button (gtk-button-new-with-label "OK"))
  113.   (gtk-signal-connect button "clicked" 
  114.               (lambda ()
  115.             (call-script procname
  116.                      (append imgargs
  117.                          (map (lambda (f) (f)) getters)))
  118.             (return)))
  119.   (gtk-box-pack-start (gtk-dialog-action-area dlg) button)
  120.   (gtk-widget-show button)
  121.  
  122.   (define button (gtk-button-new-with-label "Cancel"))
  123.   (gtk-signal-connect button "clicked" return)
  124.   (gtk-box-pack-start (gtk-dialog-action-area dlg)  button)
  125.   (gtk-widget-show button)
  126.   
  127.   (define frame (gtk-frame-new "Script Arguments"))
  128.   (gtk-box-pack-start (gtk-dialog-vbox dlg) frame)
  129.   (gtk-widget-show frame)
  130.  
  131.   (define table (gtk-table-new (length arginfo) 2 #f))
  132.   (gtk-container-add frame table)
  133.   (gtk-widget-show table)
  134.  
  135.   (define inputters
  136.     (map (lambda (arg)
  137.         ((cadr (assq (car arg) argt)) (caddr arg)))
  138.      arginfo))
  139.   (define descs (map cadr arginfo))
  140.   (define getters (map cdr inputters))
  141.   (define widgets (map car inputters))
  142.  
  143.   (let ((row 0))
  144.     (for-each (lambda (desc widget)
  145.         (define label (gtk-label-new desc))
  146.         (gtk-table-attach table label 0 1 row (+ row 1) '() '())
  147.         (gtk-widget-show label)
  148.         (gtk-table-attach table widget 1 2 row (+ row 1))
  149.         (gtk-widget-show widget)
  150.         (set! row (+ row 1)))
  151.           descs
  152.           widgets))
  153.  
  154.  
  155.   (define frame (gtk-frame-new "Current command:"))
  156.   (gtk-box-pack-start (gtk-dialog-vbox dlg) frame #f #f 0)
  157.   (gtk-widget-show frame)
  158.  
  159.   (define current-command (gtk-entry-new))
  160.   (gtk-entry-set-editable current-command #f)
  161.   (gtk-container-add frame current-command)
  162.   (set! pdb-cb (lambda (procname args)
  163.          (gtk-entry-set-text current-command procname)
  164.          (gdk-flush)))
  165.  
  166.   (gtk-widget-show current-command)
  167.  
  168.   (gtk-widget-show dlg)
  169.   (gtk-main)
  170.   (gtk-widget-destroy dlg)
  171.   (gdk-flush)
  172.   (list (cons PARAM-STATUS STATUS-SUCCESS )))
  173.  
  174.  
  175.  
  176.  
  177. (define (assert expr)
  178.   (if (not expr)
  179.       (error "Assert error: "))) 
  180.  
  181.  
  182.  
  183. ; This is an alist whose elements are of the form:
  184. ; (scriptname proc img-based (type desc default) (type desc default) ... ) 
  185.  
  186. (define sf-scriptdb '())
  187.  
  188.  
  189. (define pdb-cb list)
  190.  
  191. (define (sf-parse-param type desc default)
  192.   (let ((ti (assq type sfargtype-alist)))
  193.     (if (not (string? desc))
  194.     (error "Invalid description"))
  195.     (if (not ti)
  196.     (error "Invalid type"))
  197.     (if (not ((cadddr ti) default))
  198.     (error "Invalid default"))
  199.     (list (cadr ti) (caddr ti) desc)))
  200.     
  201.  
  202. (define (sf-parse-params-iter params parsed)
  203.   (if (null? params)
  204.        (reverse parsed)    ;paramdef
  205.       (sf-parse-params-iter
  206.        (cdr params)
  207.        (cons (apply sf-parse-param (car params)) parsed))))
  208.  
  209.  
  210. (define (group-params-iter params accum)
  211.   (if (null? params)
  212.       (reverse accum)
  213.       (group-params-iter (cdddr params) (cons (list (car params)
  214.                             (cadr params)
  215.                             (caddr params))
  216.                           accum))))
  217. (define (script-fu-register name
  218.                 desc
  219.                 help
  220.                 author
  221.                 copyright
  222.                 date
  223.                 img-types
  224.                 . params)
  225.   (define paramgrp (group-params-iter params '()))
  226.   (define parsed (sf-parse-params-iter paramgrp '()))
  227.   (define paramdefs (cons (list PARAM-INT32
  228.                 "run_mode"
  229.                 "Interactive, non-interactive")
  230.               parsed))
  231.   (define dbname (string-append gimplesf-prefix name))
  232.   (set! sf-scriptdb (cons (append (list dbname
  233.                     (symbol-binding #f (string->symbol name))
  234.                     (not (string-match "^<Toolbox>" desc)))
  235.                   paramgrp)
  236.               sf-scriptdb))
  237.  
  238.   (define menu-path
  239.     (regexp-substitute #f (string-match "Script-Fu" desc) 'pre "GimpleSF" 'post))
  240.   (gimple-install-proc
  241.    (list dbname
  242.      "A GimpleSF script"
  243.      help author copyright date menu-path img-types)
  244.    paramdefs
  245.    '())
  246. )
  247.  
  248.  
  249. (define (conv-default arg) arg)
  250.  
  251. (define (conv-string arg)
  252.   (if (string? arg)
  253.       arg
  254.       (error "argument must be a string" arg)))
  255.  
  256. (define (conv-int arg)
  257.   (if (number? arg)
  258.       (if (integer? arg)
  259.       arg
  260.       (inexact->exact (floor arg)))
  261.       (error "argument must be a number" arg)))
  262.  
  263. (define (conv-drawable arg)
  264.   (if (number? arg)
  265.       arg
  266.       (error "argument must be an integer identifier")))
  267.  
  268. (define (conv-float arg)
  269.   (if (number? arg)
  270.       arg
  271.       (error "argument must be a number")))
  272.  
  273. (define (conv-color arg)
  274.   (if (equal? (map number? arg) '(#t #t #t))
  275.       (list->vector (map conv-int arg))
  276.       (error "argument must be a color (a list of three integers)")))
  277.  
  278. (define (conv-stringarray arg)
  279.   (if (list? arg)
  280.       arg
  281.       (error "argument must be a stringarray (a list of strings)")))
  282.  
  283.  
  284.  
  285.  
  286. (define sfargtype-alist
  287.   (list
  288.    (list SF-IMAGE PARAM-IMAGE "Image" integer? id)  
  289.    (list SF-DRAWABLE PARAM-DRAWABLE "Drawable" integer? id)  
  290.    (list SF-LAYER PARAM-LAYER "Layer" integer? id)
  291.    (list SF-CHANNEL PARAM-CHANNEL "Channel" integer? id)
  292.    (list SF-COLOR PARAM-COLOR "Color"
  293.      (lambda (def)
  294.        (equal? (map integer? def) '(#t #t #t)))
  295.      vector->list)
  296.    (list SF-VALUE PARAM-STRING "Value" string?
  297.      (lambda (arg) (call-with-input-string arg read)))
  298.    (list SF-TOGGLE PARAM-INT32 "Toggle"
  299.      (lambda (def)
  300.        (or (zero? def) (= def 1))) id)))
  301.  
  302. (define gparamtype-alist
  303.   (list
  304.    (cons PARAM-INT32 conv-int)
  305.    (cons PARAM-INT16 conv-int)
  306.    (cons PARAM-INT8 conv-int)
  307.    (cons PARAM-FLOAT conv-float)
  308.    (cons PARAM-STRING conv-string)
  309.    (cons PARAM-STRINGARRAY conv-stringarray)
  310.    (cons PARAM-COLOR conv-color)
  311.    (cons PARAM-DRAWABLE conv-drawable)
  312.    (cons PARAM-IMAGE conv-drawable)
  313.    (cons PARAM-LAYER conv-drawable)
  314.    (cons PARAM-CHANNEL conv-drawable)
  315.    (cons PARAM-DISPLAY conv-drawable)
  316.    ))
  317.  
  318. (define (convert_ str)
  319.   (let ((i (string-index str #\_)))
  320.     (if i (begin
  321.         (string-set! str i #\-)
  322.         (convert_ str))
  323.     str)))
  324.  
  325.  
  326. (define (add-procedure procname)
  327.   (define sfname (symbol (convert_ (string-copy procname))))
  328.   (intern-symbol #f sfname)
  329.   (symbol-set! #f sfname
  330.            (lambda args
  331.          (apply proc-run-check procname args))))
  332.  
  333.  
  334.  
  335. (define (listify-path-iter path idx accum)
  336.   (define i (string-index path #\: idx))
  337.   (if i
  338.       (listify-path-iter path
  339.              (+ i 1)
  340.              (cons (substring path idx i) accum))
  341.       (reverse (cons (substring path idx (string-length path)) accum))))
  342.  
  343.       
  344. (define (read-scripts dirname)
  345.   (if (access? dirname (logior R_OK X_OK))
  346.   (let ((dir (opendir dirname)))
  347.     (do ((file (readdir dir) (readdir dir)))
  348.     ((eof-object? file) #t)
  349.       (if (string-match "\.scm$" file)
  350.       (catch #t
  351.          (lambda ()
  352.            (load (string-append dirname "/" file)))
  353.          (lambda (key . args)
  354.            (warn "Error" key args "processing file" file))))))
  355.   #f))
  356.   
  357.  
  358. (define (find-scripts)
  359.   (define path (listify-path-iter
  360.         (car (gimp-gimprc-query "gimplesf-path")) 0 '()))
  361.   ;Just a temp thingy
  362.   (define omap map)
  363.   (define ofor-each for-each)
  364. ;  (define oset! set!)
  365. ;  (oset! set! define)
  366.   (for-each read-scripts path)
  367. ;  (oset! set! oset!)
  368.   (set! for-each ofor-each)
  369.   (set! map omap))
  370.   
  371.  
  372.   
  373. (define (proc-param-type proc npar)
  374.   (cdr (cadr (gimple-run-pdb
  375.               "gimp_procedural_db_proc_arg"
  376.               proc
  377.               (cons PARAM-INT32 npar)))))
  378.  
  379. (define (proc-param-types-iter proc idx accum)
  380.   (if (= idx -1)
  381.       accum
  382.       (proc-param-types-iter proc (- idx 1)
  383.                  (cons
  384.                   (proc-param-type proc idx)
  385.                   accum))))
  386.        
  387. (define (proc-param-types proc)
  388.   (proc-param-types-iter 
  389.    (cons PARAM-STRING proc)
  390.    (- (cdr (list-ref (gimple-run-pdb "gimp_procedural_db_proc_info"
  391.                      (cons PARAM-STRING proc))
  392.              7))
  393.       1)
  394.    '()))
  395.  
  396.  
  397.  
  398. (define (params-to-sfargs params argtypes)
  399.   (map (lambda (param argtype)
  400.      ((list-ref (assq (car argtype) sfargtype-alist) 4) (cdr param))); Would be good to check the param type
  401.        params
  402.        argtypes))
  403.  
  404. (define (proc-run procname . args)
  405.   (define argtypes (proc-param-types procname))
  406.   (map cdr (apply gimple-run-pdb procname (map cons argtypes args))))
  407.  
  408. (define (revconv gparam)
  409.   (if (eq? (car gparam) PARAM-COLOR)
  410.       (vector->list (cdr gparam))
  411.       (cdr gparam)))
  412.  
  413. (define (proc-run-check procname . args)
  414.   (if (not (string? procname))
  415.       (error "procname must be a string"))
  416.   (define argtypes (proc-param-types procname))
  417.   (if (not (= (length args) (length argtypes)))
  418.       (error "wrong number of args"))
  419.   (define pdbargs
  420.     (map (lambda (argtype arg)
  421.        (cons argtype ((cdr (assq argtype gparamtype-alist)) arg)))
  422.      argtypes
  423.      args))
  424.   (pdb-cb procname args)
  425.   (define retvals (apply gimple-run-pdb procname pdbargs))
  426.   (if (equal? (car retvals) (cons PARAM-STATUS STATUS-SUCCESS ))
  427.       (map revconv (cdr retvals))
  428.       (error "Error at pdb execution")))
  429.       
  430. (define gimp-proc-db-call proc-run-check)
  431.  
  432. (define (call-script procname sfargs)
  433.   (define oset! set!)
  434.   (set! set! define)
  435.   (apply
  436.    (cadr (assoc procname sf-scriptdb))
  437.    sfargs)
  438.   (oset! set! oset!))
  439.  
  440.  
  441. (define (sf-dispatcher procname . args)
  442.   (catch #t
  443.      (lambda ()
  444.        (define run-type (car args))
  445.        (if (eq? (car run-type) PARAM-INT32)
  446.            (case (cdr run-type)
  447.          ;RUN-INTERACTIVE
  448.          ((0) (run-script-interactive procname (cdr args)))
  449.          ;RUN-NONINTERACTIVE
  450.          ((1)
  451.           (set! pdb-cb list)
  452.           (let* ((argtypes (cdddr (assoc procname sf-scriptdb)))
  453.                  
  454.              ; Convert the GParams to SFArgs
  455.              (sfargs (params-to-sfargs (cdr args);discard run_type
  456.                                argtypes)))
  457.             ; Call the script
  458.             (call-script procname sfargs)
  459.             (list (cons PARAM-STATUS STATUS-SUCCESS)))))
  460.            (list (cons PARAM-STATUS STATUS-CALLING-ERROR))))
  461.      (lambda err
  462.        (warn err)
  463.        (list (cons PARAM-STATUS STATUS-EXECUTION-ERROR)))))
  464.  
  465.  
  466.  
  467. ;SIOD compatibility stuff
  468.  
  469. (define (fmod nom den) (- nom (* (truncate (/ nom den)) den)))
  470. (define (nth i l) (list-ref l i))
  471. (define *pi* (* 4 (atan 1)))
  472. (define cons-array make-vector)
  473. (define aset vector-set!)
  474. (define aref vector-ref)
  475. (define pow expt)
  476. (defmacro prog1 (first . rest)
  477.   (define tmp (gensym))
  478.   `(begin (define ,tmp ,first)
  479.       ,@rest
  480.       ,tmp))
  481.  
  482.  
  483.  
  484. (debug-set! depth 50)
  485.  
  486. (define (sf-init)
  487.   (define x (cons PARAM-STRING ".*"))
  488.   (define allprocs (gimple-run-pdb "gimp_procedural_db_query" x x x x x x x))
  489.   (if (not (equal? (car allprocs) (cons PARAM-STATUS STATUS-SUCCESS)))
  490.       (error "initial pdb query failed!"))
  491.   (define proclist (vector->list (cdaddr allprocs)))
  492.   (for-each add-procedure proclist)
  493.   )
  494.  
  495.  
  496. (sf-init)
  497. (define gimp-data-dir (car (gimp-gimprc-query "gimp_data_dir")))
  498. (define gimp-plugin-dir (car (gimp-gimprc-query "gimp_plugin_dir")))
  499. (define gimplesf-prefix (car (gimp-gimprc-query "gimplesf-prefix")))
  500.  
  501. (find-scripts)
  502. ;maybe this should be done earlier.. gimp blocks until this..
  503. (gimple-extension-ack)
  504.  
  505. ;(top-repl)
  506.  
  507. ;this is an infinite loop in scheme-style
  508. ((lambda (f) (f f))
  509.  (lambda (g)
  510.    (gimple-extension-process sf-dispatcher 0)
  511.    (g g)))
  512.