PROCedimientos y FuNciones

Subforo oficial del Sinclair QL: realiza aquí las consultas relativas a tu QL.

Moderador: Sir Cilve Sinclair

PROCedimientos y FuNciones

Notapor badaman el Jue Nov 20, 2008 9:53 am

Inicio aquí un hilo para ir recopilando todos aquellos procedimientos y funciones que pueden ser de utilidad a un programador de SuperBASIC.

Este hilo tiene la doble "función" de servir de recordatorio para la programación y de aprendizaje para los que se acerquen por primera vez al SuperBASIC.

Básicamente aquí lo que encontrarás son rutinas de programación que buenamente pudieron haberse escrito para otros lenguajes estructurados pero que han sido creadas o adaptadas al lenguaje por defecto del QL.

Así que, si tienes alguna rutina de la que te sientas especialmente satisfecho, o simplemente quieres recordar tus momentos de gloria con el teclado, pues sólo tienes que seguir el hilo.
Sinclair QL, la respuesta profesional de los 80
Avatar de Usuario
badaman
Sabreman
 
Mensajes: 474
Registrado: Mar Ene 29, 2008 11:58 am

Re: PROCedimientos y FuNciones

Notapor afx el Vie Dic 12, 2008 9:47 pm

Algunas funciones y procedimientos clásicos que usan la recursividad como estrategia de solución.

Autor: Dilwyn Jones
Mas info en: http://217.126.211.48/DocsQL/Recursividad.pdf

Exploración de directorios.
Código: Seleccionar todo
100 REMark extended dir of all sub-directories
110 Extended_DIR 'win1_',''
120 :
130 DEFine PROCedure Extended_DIR (drive$,directory$)
140   LOCal loop,ch,d$,fp,n$
150   ch = FOP_DIR (drive$&directory$) : REMark open channel to
directory
160   IF ch < 0 THEN RETurn : REMark unable to open directory
170   fp = 14 : REMark file position in directory for filename
180   REPeat loop
190     BGET #ch: IF EOF(#ch) THEN CLOSE #ch : EXIT loop
200     GET #ch,d$ : REMark get directory entry name
210     IF LEN(d$) > 0 THEN
220       REMark a directory length of 0 may be a deleted file
230       BGET #ch: REMark file type byte
240       IF CODE(INKEY$(#ch)) = 255 THEN
250         REMark this name is a subdirectory, so we need to DIR this
260         REMark if you want directory names printed, add this
270         REMark PRINT d$;' ->'
280         Extended_DIR drive$,d$
290       ELSE
300         PRINT d$
310       END IF
320     END IF
330     fp = fp + 64
340   END REPeat loop
350 END DEFine Extended_DIR


Un clásico, algorítmo de ordenación quicksort
Código: Seleccionar todo
100 Q_Sort array_name$,0,entries%-1
110 :
120 DEFine PROCedure Q_Sort (array$,bottom,top)
130   LOCal sort_loop,low,high,ptr
140   low  = bottom
150   high = top
160   ptr  = bottom
170   REPeat sort_loop
180     IF low >= high THEN EXIT sort_loop
190     IF array$(low) > array$(high) THEN
200       REMark need to swap these strings
210       temp$        = array$(low)
220       array$(low)  = array$(high)
230       array$(high) = temp$
240       REMark how do we shuffle pointers to sections
250       IF ptr = low THEN
260         low = low + 1
270         ptr = high
280       ELSE
290         high = high - 1
300         ptr  = low
310       END IF
320     ELSE
330       IF ptr = low THEN high = high - 1 : ELSE low = low + 1
340     END IF
350   END REPeat sort_loop
360   IF ABS(top - bottom) < 2 THEN RETurn : REMark can't sort 1 item!
370   Q_Sort array$,bottom,ptr - 1
380   Q_Sort array$,ptr + 1,top
390 END DEFine Q_Sort


Otro clásico en el estudio de la recursividad, puzzle Torres de Hanoi
Código: Seleccionar todo
100 REMark Towers of Hanoi puzzle
110 INPUT'How many rings > ';rings
120 Hanoi rings,1,2,3
130 :
140 DEFine PROCedure Hanoi(r,peg_a,peg_b,peg_c)
150   IF r = 0 THEN RETurn
160   Hanoi r-1,peg_a,peg_c,peg_b
170   PRINT'Move ring ';r;' from peg ';peg_a;' to peg ';peg_b
180   Hanoi r-1,peg_c,peg_b,peg_a
190 END DEFine Hanoi
afx
Sabreman
 
Mensajes: 396
Registrado: Dom Feb 24, 2008 11:56 pm

Re: PROCedimientos y FuNciones

Notapor badaman el Sab Dic 13, 2008 9:05 pm

Sería muy interesante si, en unas líneas generales, expusieras el funcionamiento de la rutina para la resolución de sudokus que creaste para el juego OSUSQ.

Ese es un estupendo ejemplo del uso de la recursividad en un programa.
Sinclair QL, la respuesta profesional de los 80
Avatar de Usuario
badaman
Sabreman
 
Mensajes: 474
Registrado: Mar Ene 29, 2008 11:58 am

Re: PROCedimientos y FuNciones

Notapor afx el Mar Dic 16, 2008 9:10 pm

badaman escribió:Sería muy interesante si, en unas líneas generales, expusieras el funcionamiento de la rutina para la resolución de sudokus que creaste para el juego OSUSQ.

El procedimiento de resolución del sudoku en el juego usa la recursividad para su resolución y concretamente un algoritmo clásico llamado backtracking, que es básicamente un algoritmo recursivo pero con vuelta atrás para retomar otro "camino" diferente en caso de no encontrar una solución. Es un algoritmo de "fuerza bruta", es decir explora "a lo bestia" todas las posibilidades. No es un algoritmo muy óptimo pero funciona. (El que se implementa aquí creo que se podría optimizar intentando evitar comprobaciones innecesarias, aunque no sé si el coste final sería menor).

Por simplicidad he extraído el siguiente código del juego que genera la solución empleando dicho algoritmo recursivo. En este caso es el la FuNction Generar().

Esta función emplea tres parámetros, el primero es un array de 9x9 de enteros que contiene el planteamiento del sudoku a resolver (el valor 0 en una posición es un hueco vacío), valores <> 0 indican números del planteamiento del problema. Los dos parámetros siguientes son fila, columna donde empezará la búsqueda (1,1 en la primera llamada).

Lo que hace la función básicamente es empezar a rastrear la matriz y buscar un hueco (donde haya un valor 0). Luego intentar buscar en ese hueco el primer valor válido (de 1 a 9 cumpliendo las relgas del sudoku, esto es, que el valor no se repita en la fila, columna o sección). Aquí usa una rutina de apoyo que no está en este trozo de código por simplicidad, dicha función es obvia (ver código del juego para detalle de esas rutinas, ValidaNumero()).

A partir de este punto la función llega la sección crítica, si encuentra un valor válido avanza llamándose a si misma pero con la búsqueda de un nuevo hueco. Si no encuentra un valor válido en este punto (fila, columna) debe retroceder a la llamada anterior para intentarlo con el siguiente valor (de la llamada anterior), es decir "otro camino".

La condición de parada es que se llegue a la última posición del array (posición 9,9) y que en dicha posición se encuentre un valor válido. Entonces el sudoku tendrá solución, si no es así entonces NO habrá solución. Podría pasara también que el programa agotara todas las valores en todas las retroceda sin encontrar solución.

Bueno .... no sé si me he enrollado mucho, el extracto de código es el siguiente y como dice badaman es un buen ejemplo de la potencia de la recursividad:

Código: Seleccionar todo
3540 REMark ...
3610 :
3620 solucion% = Generar (sk%, 1, 1)
3630 :
3650 IF solucion% <> 0 THEN
3660     Mensaje "³³ EL SUDOKU TIENE SOLUCI–N !!", 1
3670 ELSE
3680     Mensaje "³³ JOOOPP  EL SUDOKU NO TIENE SOLUCI–N !!", 1
3690 END IF
3700 :
3710 :
3740 REMark --- Funci–n recursiva (tipo backtracking) para solucionar el sudoku
3750 DEFine FuNction Generar(sk%, fil, col)
3760    LOCal num%: LOCal res%
3770    LOCal f, c
3780    LOCal sol%
3790    :
3800    REMark Avanzar hasta encontrar una posici–n libre
3810    REPeat BuscaHueco
3820       IF fil > 9 OR col> 9 THEN sol%=1: RETurn sol%
3830       IF sk%(fil,col) = 0  THEN
3840          EXIT BuscaHueco
3850       END IF
3860       col = col + 1
3870       IF col > 9 THEN
3880          col = 1
3890          fil = fil + 1
3900       END IF
3910    END REPeat BuscaHueco
3920    :
3930    sol% = 0
3940    num% = 0
3950    REMark Rastrear todos los n™meros del sudoku del 1 al 9
3960    REPeat  BuscaNumero
3970       num% = num% + 1
3980       res% = ValidaNumero(sk%, num%, fil, col)
3990       REMark PRINT#0, num%;res%: INPUT#0, "> ";b$
4000       IF res% <> 0 THEN
4010          sk%(fil,col) = num%
4020          PintaCasilla num%, fil, col, 0
4030          f = fil
4040          c = col + 1
4050          IF c > 9 THEN
4060             f = f + 1
4070             c = 1
4080          END IF
4090          REMark Llamada recursiva si llega al final
4100          REMark  estamos en la condici–n de parada
4110          IF f < 10 THEN
4120             sol% = Generar (sk%, f, c)
4130          ELSE
4140             sol% = 1
4150          END IF
4160       END IF
4170       IF sol% = 1 OR num% = 9 THEN
4180          EXIT BuscaNumero
4190       END IF
4200    END REPeat BuscaNumero
4210    :
4220    IF sol% = 0 THEN
4230        sk%(fil,col) = 0
4240        PintaCasilla 0, fil, col, 0
4250    END IF
4260    RETurn sol%
4270 END DEFine
4280 :
4290 :

afx
Sabreman
 
Mensajes: 396
Registrado: Dom Feb 24, 2008 11:56 pm

Re: PROCedimientos y FuNciones

Notapor afx el Vie Ene 23, 2009 7:58 pm

Colección de rutinas para detectar el "hardware" del QL.
Autor: J.D.Mitchell.

Código: Seleccionar todo
10000 REMark *****************************
10010 REMark Version: V1.0
10020 REMark Date: 20/Sep/1997
10030 REMark Author: J.D.Mitchell
10040 REMark EMAIL: Jack@home9999.demon.co.uk
10050 REMark Change: 1) Default system vars base is at 160K not 128K
10060 REMark 2) Add change control header
10070 REMark *****************************
10080 REMark Version: 1.1
10090 REMark Date: 20/Sep/1997
10100 REMark Author: J.D.Mitchell
10110 REMark EMAIL: Jack@home9999.demon.co.uk
10120 REMark Change: 1) Use peek(!!addr) etc. when possible
10130 REMark *****************************
10140 REMark Version: 1.2
10150 REMark Date: 28/Nov/1997
10160 REMark Author: J.D.Mitchell
10170 REMark EMAIL: Jack@home9999.demon.co.uk
10180 REMark Change: 1) Corect error in change history
10190 REMark Change: 2) Report QDOS versions as ROM names not versions
10200 REMark *****************************
10210 DEFine FuNction DISPLAY_WIDTH
10220   IF os$='SMSQE' THEN RETurn SCR_XLIM
10230   RETurn scr__lim%('scr_','x256a0x0')&&-2
10240 END DEFine
10245 :
10250 DEFine FuNction display_height
10260   IF os$='SMSQE' THEN RETurn SCR_YLIM
10270   RETurn scr__lim%('scr_512x','a0x0')
10280 END DEFine
10285 :
10290 DEFine FuNction scr__lim%(prefix$,sufix$)
10300   LOCal h_max%,h_min%,h%,loop
10310   h_max%=1280
10320   h_min%=256
10330   REPeat loop
10340     h%=(h_max%+h_min%+1)DIV 2
10350     IF h%>h_max% THEN h%=h_max%
10360     IF FTEST(prefix$&h%&sufix$)=0 THEN
10370       h_min%=h%
10380     ELSE
10390       h_max%=h%-1
10400     END IF
10410     IF h_min%=h_max% THEN RETurn h_max%
10420   END REPeat loop
10430 END DEFine
10435 :
10440 REMark mimics peek_w(!!addr)
10450 DEFine FuNction peek_w_sys(addr)
10460   IF os$='QDOS' THEN
10470     RETurn PEEK_W(addr+sys_vars_base)
10480   END IF
10490   RETurn PEEK_W(!!addr)
10500 END DEFine
10505 :
10510 REMark mimics peek(!!addr)
10520 DEFine FuNction peek_sys(addr)
10530   IF os$='QDOS' THEN
10540     RETurn PEEK(addr+sys_vars_base)
10550   END IF
10560   RETurn PEEK(!!addr)
10570 END DEFine
10575 :
10580 REMark mimics peek_l(!!addr)
10590 DEFine FuNction peek_l_sys(addr)
10600   IF os$='QDOS' THEN
10610     RETurn PEEK_L(addr+sys_vars_base)
10620   END IF
10630   RETurn PEEK_L(!!addr)
10640 END DEFine
10645 :
10650 DEFine PROCedure setup_read
10660   LOCal hardware_code,cpu_code,display_code,sys_vars_base,monitor_code,display_register
10670   IF VER$<>'HBA' THEN
10680     IF VER$='JSL1' THEN
10690       os$='Minerva'
10700       version$=VER$(1)
10710       sys_vars_base=VER$(-2)
10720       lang$='GB'
10730     ELSE
10740       os$='QDOS'
10750       version$=VER$
10760       sys_vars_base=(128+32)*1024
10770       IF LEN(version$)<=2 THEN
10780         lang$='GB'
10790       ELSE
10800         lang$=version$(3 TO)
10810       END IF
10820     END IF
10830   ELSE
10840     IF FTEST('history_1024')<>0 THEN
10850       os$='SMSQ'
10860     ELSE
10870       os$='SMSQE'
10880     END IF
10890     sys_vars_base=VER$(-2)
10900     version$=VER$(1)
10910     lang$=LANGUAGE$
10920    END IF
10930    REMark mimics  PROCESSOR   provided by SMSQE
10940    cpu_code=(peek_sys(161) DIV 16)*10
10950    REMark mimics  MACHINE     provided by SMSQE
10960    hardware_code=peek_sys(167)&&31
10970    REMark mimics  DISP_TYPE   provided by SMSQE but gives 6 for VGA on a QXL
10980    display_code=peek_sys(167) DIV 32
10990    display_register=peek_sys(52)
11000    freq=peek_w_sys(168)
11010    SELect freq
11020      =50,60
11030      =REMAINDER :freq=50
11040    END SELect
11050    ram_top=peek_l_sys(32)
11060    monitor_code=peek_sys(50)
11070    REMark Convert to text
11080    SELect ON hardware_code
11090      =0:hardware$='Standard QL'
11100      =1:hardware$='Atari'
11110      =2,3:hardware$='Mega/RTC ST'
11120      =4,5:hardware$='Stacy'
11130      =6,7:hardware$='STE'
11140      =8,9:hardware$='Mega STE'
11150      =10,11:hardware$='GOLD card'
11160      =12,13:hardware$='Super Gold card'
11170      =16:hardware$='Falcon'
11180      =24:hardware$='TT 030'
11190      =28:hardware$='QXL'
11200      =30:hardware$='QPC'
11210      =31:hardware$='QLAY'
11220      =REMAINDER :hardware$='Unknown HW('&hardware_code&')'
11230    END SELect
11240    SELect hardware_code
11250      =1,3,5,7,9:add_on$='Blitter'
11260      =11,13:add_on$='Hermes'
11270      =REMAINDER :add_on$=''
11280    END SELect
11290    SELect ON monitor_code
11300      =0:monitor$='Monitor'
11310      =1:monitor$='625 line TV'
11320      =2:monitor$='525 line TV'
11330      =REMAINDER :monitor$='Unknown Monitor('&monitor_code&')'
11340    END SELect
11350    display_mode=4+(display_register&&8)DIV 2
11360    display_page=display_register DIV 128
11370    SELect display_code
11380      =0:display$='Standard'
11390      =1:display$='Monochrome'
11400      =2:display$='Extended 4 emulator'
11410      =4:display$='QMVE'
11420      =5:display$='Aurora'
11430      =6:display$='VGA'
11440      =REMAINDER :display$='Unknown display('&display_code&')'
11450    END SELect
11460    SELect cpu_code
11470      =0:cpu$='68000/68008'
11480      =10:cpu$='68010'
11490      =20:cpu$='68020'
11500      =30:cpu$='68030'
11510      =40:cpu$='68040'
11520      =REMAINDER :cpu$='Unknown CPU('&cpu_code&')'
11530    END SELect
11540 END DEFine
11545 :
11550 DEFine PROCedure setup_show(chan%)
11560   PRINT#chan%,'Running ';os$;
11570   IF os$=='QDOS' THEN
11580     PRINT#chan%,' ';version$;' ROM'
11590   ELSE
11600     PRINT#chan%,' V';version$
11610   END IF
11620   PRINT#chan%,'On a ';cpu$;' powered ';hardware$
11630   PRINT#chan%,'With ';INT(ram_top/1024)-128;'KByte RAM';
11640   IF add_on$<>'' THEN PRINT#chan%,' and ';add_on$
11650   PRINT#chan%,\'Using ';display$;' ';DISPLAY_WIDTH;'x';display_height;' on a ';monitor$
11660   PRINT#chan%,'Displaying ';position_name$(display_page+1);' page in mode ';display_mode
11670   PRINT#chan%,'Country ';lang$;' @';freq;'Hz'
11680 END DEFine
11685 :
11690 DEFine FuNction position_name$(n)
11700   SELect n
11710     =1:RETurn '1st'
11720     =2:RETurn '2nd'
11730     =3:RETurn '3rd'
11740     =REMAINDER :RETurn n&'th'
11750   END SELect
11760 END DEFine
11765 :
11770 DEFine PROCedure setup_test
11780   TK2_EXT
11790   setup_read
11800   CLS
11810   setup_show #1
11820 END DEFine
11825 :
11830 setup_test
afx
Sabreman
 
Mensajes: 396
Registrado: Dom Feb 24, 2008 11:56 pm

Re: PROCedimientos y FuNciones

Notapor badaman el Sab Feb 07, 2009 12:28 am

Si se conoce la altura y anchura de una ventana y la escala vertical, podemos predecir cuantos puntos en el sistema de coordenadas horizontal serán visibles dentro de la ventana en cuestión. Es decir, cuantos puntos de ancho mide la ventana. (estos puntos, por la escala aplicada, no se corresponden con los pixels reales de pantalla)

La siguiente función devuelve este valor:

Código: Seleccionar todo
1000 DEFine FuNction X_Scale(y_scale,wide,high)
1010   RETurn 0.75 * y_scale * wide / high
1020 END DEFine X_Scale
Sinclair QL, la respuesta profesional de los 80
Avatar de Usuario
badaman
Sabreman
 
Mensajes: 474
Registrado: Mar Ene 29, 2008 11:58 am


Volver a Sinclair QL

¿Quién está conectado?

Usuarios navegando este Foro: No hay usuarios registrados visitando el Foro y 1 invitado