REBOL [
	TITLE: "colorisation syntaxique"
	auteur: "Shadwolf"
	date: 18/03/2009 
	purpose: {offert the rendering in colorized text in a 'box using draw/agg }
]
comment {
 Todo:
  commençons simplement par charger un fichier source rebol et 
  a l'afficher en couleur dans une 'box en read only en utilisant 
  draw/agg (font fixe seul la couleur varie)
  Par la suite quand on aura un beau résultat a l'ecran et une bonne 
  structure mémoire/ rendu nous pourrons nous occupé de l'aspect saisie de texte dynamique.  

**** idée a creuser ( utilisation de push [] dans le draw block!)
  1 sous block d'ascii-tab = 1 ligne de texte  = 1 sous block de draw

avec ce systèmes pour scroller d'une ligne vers les bas c'est simple.
1/ tu enlèves le premier bloc du block draw
2/ tu crées un nouveaus push block à la fin 
3/ et tu fais un show.

hop c'est tout
  (moins de recalcul)
  draw: [
translate 0x15 push [...]   ;ligne 1
translate 0x15 push [...]   ;ligne 2
...

]
  
}

script-color-ctx: context  [
; contient les fonctions pour convertir le texte ascii brute en instructions AGG
 colors: [
         char!          0.120.40
         date!          0.120.150
         decimal!       0.120.150
         email!         0.120.40
         file!          0.120.40
         integer!       0.120.150
         issue!         0.120.40
         money!         0.120.150
         pair!          0.120.150
         string!        0.120.40
         tag!           0.120.40
         time!          0.120.150
         tuple!         0.120.150
         url!           0.120.40
         refinement!    160.120.40
         cmt            10.10.160
    ]

    out: none

    emit: func [data] [repend out data]


    emit-color: func [value start stop /local color][
        either none? :value [color: select colors 'cmt][
            if path? :value [value: first :value]
            color: either word? :value [
                any [
                    all [value? :value any-function? get :value 140.0.0]
                    all [value? :value datatype? get :value 120.60.100]
                ]
            ][
                any [select colors type?/word :value]
            ]
        ]
        either color [ ; (Done this way so script can color itself.)
            emit [ color 
                copy/part start stop ]
        ][
            emit copy/part start stop
        ]
    ]
    char-array: make block! [60]
	get-string: func [char][
		any [
			select/case char-array char 
			first back change insert tail char-array char to-string char
		]
	]
; fonction globalisée pour être appellée depuis l'exterrieur
    set 'color-code func [ 
        "Return color source code as HTML."
        text [string!] "Source code text"
        /local str new value
    ][
        ;out: make string! 3 * length? text
		out: copy []
        set [value text] load/next  text
        emit copy/part head text text
        spc: charset [#"^(1)" - #" "] ; treat like space

        parse/all text blk-rule: [
            some [
                str:
                some spc new: (emit copy/part str new) |
                newline (emit newline)|
                #";" [thru newline | to end] new: 
                    (emit-color none str new) |
                [#"[" | #"("] (emit get-string first str) blk-rule |
                [#"]" | #")"] (emit get-string first str) break |
                skip (
                    set [value new] load/next str
                    emit-color :value str new
                ) :new
            ]
        ]

      ; probe out ; dbg  
       return out
    ]
]





area-tc-ctx: context  [

	; steeve's suggestion to save memory	
	char-array: make block! [60]
	get-string: func [char][
		any [
			select/case char-array char 
			first back change insert tail char-array char to-string char
		]
	]

	set 'open-file func [ /local file  ] [
		recycle
		file: request-file
		if file [ 
			render-text t create-ascii-tab color-code read first file 
		] 
	]
	
	create-ascii-tab: func [ tdm-data 
	/local cur-color def-color
	item  
	letter
	ascii-tab
	ascii-line
	curr-off
	w z
	]
	[
		cur-color: 0.0.0
		def-color: 0.0.0
		curr-off: 5X5
		ascii-tab: copy []
		ascii-line: copy []
		;w: make face compose [ font [size: 14] ] ; steeve's suggestion 
		w: make face [ font [size: 14] ]
		;cette fonction converti les données TDM (lue depuis le fichier traitée par color-color
		; en donnée draw
		foreach item tdm-data [ 
			if (type? item) = tuple! [ cur-color: :item ]
			if (type? item) = any [ string! char! ] [
; partie compliquée...
; on prend chaque donnée de string et l'insert dans le block de donnée.
; [[[][][]] [[][][]...] ]
				
				foreach letter  item [
					;probe item
					;probe letter 
					letter: get-string letter ; steeve's suggestion
					switch/default letter [
						"^/" [
							;insert tail ascii-line compose/deep [ (curr-off)  (letter) (cur-color)]
							;insert tail ascii-tab compose [ (ascii-line)]
							insert insert insert tail ascii-line curr-off  letter cur-color 
							insert tail ascii-tab  ascii-line
							
							ascii-line: copy [] 
							curr-off/x: 5 
							curr-off/y: curr-off/y + 18
								 
						]
						"^-" [ curr-off/x: curr-off/x + 20 ] ;tab
						
						
						;#" " [ cur-color: 0.0.0]
					][
						insert insert insert tail ascii-line curr-off letter cur-color
; on incremente curr-off pour le prochain ascii
;on utilise la métode de calcul de taille simplifiée de Coccinelle size-text marche très bien ^^ 
					w/text: letter
					z: size-text w
    				curr-off/x: curr-off/x + z/x 
    				;probe curr-off
    				;recycle		
					]
						;halt; dbg
				]
				cur-color: 0.0.0 ; remise a default de la couleur	
			]
		
		]; fin premier foreach
		;probe ascii-tab ; dbg
		w: z: none 
		return ascii-tab  
	]

	render-text: func [ fac key 
	/local pos char color font-obj draw-txt
	prev-col
	][	
		draw-txt: copy []
		prev-col: none
		;probe key ;dbg
		font-obj: make face/font [ size: 14]
		insert draw-txt ['font font-obj ] 
		foreach [ pos char  color ] key  [
			;probe color 
			if color <> prev-col [
				insert insert tail draw-txt 'pen color 
			]
			insert insert insert tail  draw-txt 'text pos char 
			prev-col: :color
		]
		;probe draw-txt
		fac/effect: none 
		fac/effect: compose/only [ draw (draw-txt) ]
		show fac
		
		recycle
		;print "fin de render-text"
	]
	
	stylize/master [
		area-tc: box with [
			color: white 
			text-cursor-position: none ;postion courante du curseur
		    start-higlight: none ; début sélection
			end-highlight: none ; fin sélection
	    	highlight-cnt: none ; contenu de la séléction
	    
			feel: make feel [
				detect: func [f event] [
					if event/type == 'down [
						f/colors: ['black 'white]
						focus f 
					]	
					
					event	
				] 
				
				engage: func [f a e /local key] [
					switch a [
						key [
							key: e/key
							switch/default key [
								#"^M" [ ; touche entrer
							 	; pas implémenter pour l'instant
								]
								#"^[" [ ;touche escape ne fait rien
								]
								#"^~" [ ; touche suppr
								;A FAIRE
								]	
								right [ ; A FAIRE 
								]
								left [ ; A FAIRE 
								]
								down [ ; A FAIRE 
								]
								up [ ; A FAIRE 
								]
								
							][ ; insertion d'un char
								render-text f key
							]
						
						]
					] ;fin switch   
				]; fin engage
	
			] ; fin feel:
		]
	]
]




view layout  [
	below
	btn "open" [ open-file ]
	t: area-tc 600x800
	btn "dbg" [ do %../Anamonitor.r ]
	btn "Quit" [quit]
]